#' @include zzz.R
#' @include generics.R
#' @include assay.R
#' @include command.R
#' @include dimreduc.R
#' @include graph.R
#' @include spatial.R
#' @importFrom methods setClass
#' @importClassesFrom Matrix dgCMatrix
#'
NULL

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Class definitions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#' The Seurat Class
#'
#' The Seurat object is a representation of single-cell expression data for R;
#' each Seurat object revolves around a set of cells and consists of one or more
#' \code{\link{Assay}} objects, or individual representations of
#' expression data (eg. RNA-seq, ATAC-seq, etc). These assays can be reduced
#' from their high-dimensional state to a lower-dimension state and stored as
#' \code{\link{DimReduc}} objects. Seurat objects also
#' store additional metadata, both at the cell and feature level (contained
#' within individual assays). The object was designed to be as self-contained as
#'  possible, and easily extendable to new methods.
#'
#' @slot assays A list of assays for this project
#' @slot meta.data Contains meta-information about each cell, starting with
#' number of features detected (nFeature) and the original identity class
#' (orig.ident); more information is added using \code{\link{AddMetaData}}
#' @slot active.assay Name of the active, or default, assay; settable using
#' \code{\link{DefaultAssay}}
#' @slot active.ident The active cluster identity for this Seurat object;
#' settable using \code{\link{Idents}}
#' @slot graphs A list of \code{\link{Graph}} objects
#' @slot neighbors ...
#' @slot reductions A list of dimensional reduction objects for this object
#' @slot images A list of spatial image objects
#' @slot project.name Name of the project
#' @slot misc A list of miscellaneous information
#' @slot version Version of Seurat this object was built under
#' @slot commands A list of logged commands run on this \code{Seurat} object
#' @slot tools A list of miscellaneous data generated by other tools, should be
#' filled by developers only using \code{\link{Tool}<-}
#'
#' @name Seurat-class
#' @rdname Seurat-class
#' @exportClass Seurat
#'
Seurat <- setClass(
  Class = 'Seurat',
  slots = c(
    assays = 'list',
    meta.data = 'data.frame',
    active.assay = 'character',
    active.ident = 'factor',
    graphs = 'list',
    neighbors = 'list',
    reductions = 'list',
    images = 'list',
    project.name = 'character',
    misc = 'list',
    version = 'package_version',
    commands = 'list',
    tools = 'list'
  )
)

#' The Seurat Class
#'
#' The Seurat object is the center of each single cell analysis. It stores all
#' information associated with the dataset, including data, annotations,
#' analyses, etc. All that is needed to construct a Seurat object is an
#' expression matrix (rows are genes, columns are cells), which should
#' be log-scale
#'
#' Each Seurat object has a number of slots which store information. Key slots
#' to access are listed below.
#'
#' @slot raw.data The raw project data
#' @slot data The normalized expression matrix (log-scale)
#' @slot scale.data scaled (default is z-scoring each gene) expression matrix;
#' used for dimensional reduction and heatmap visualization
#' @slot var.genes Vector of genes exhibiting high variance across single cells
#' @slot is.expr Expression threshold to determine if a gene is expressed
#' (0 by default)
#' @slot ident THe 'identity class' for each cell
#' @slot meta.data Contains meta-information about each cell, starting with
#' number of genes detected (nFeature) and the original identity class
#' (orig.ident); more information is added using \code{AddMetaData}
#' @slot project.name Name of the project (for record keeping)
#' @slot dr List of stored dimensional reductions; named by technique
#' @slot assay List of additional assays for multimodal analysis; named by
#' technique
#' @slot hvg.info The output of the mean/variability analysis for all genes
#' @slot imputed Matrix of imputed gene scores
#' @slot cell.names Names of all single cells
#' (column names of the expression matrix)
#' @slot cluster.tree List where the first element is a phylo object containing
#' the phylogenetic tree relating different identity classes
#' @slot snn Spare matrix object representation of the SNN graph
#' @slot calc.params Named list to store all calculation-related
#' parameter choices
#' @slot kmeans Stores output of gene-based clustering from \code{DoKMeans}
#' @slot spatial Stores internal data and calculations for spatial mapping of
#' single cells
#' @slot misc Miscellaneous spot to store any data alongside the object
#' (for example, gene lists)
#' @slot version Version of package used in object creation
#'
#' @name seurat-class
#' @rdname oldseurat-class
#' @aliases seurat-class
#'
#' @concept unsorted
#'
#' @keywords internal
#'
seurat <- setClass(
  Class = "seurat",
  slots = c(
    raw.data = "ANY",
    data = "ANY",
    scale.data = "ANY",
    var.genes = "vector",
    is.expr = "numeric",
    ident = "factor",
    meta.data = "data.frame",
    project.name = "character",
    dr = "list",
    assay = "list",
    hvg.info = "data.frame",
    imputed = "data.frame",
    cell.names = "vector",
    cluster.tree = "list",
    snn = "dgCMatrix",
    calc.params = "list",
    kmeans = "ANY",
    spatial = "ANY",
    misc = "ANY",
    version = "ANY"
  )
)

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Functions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#' Query Specific Object Types
#'
#' List the names of \code{\link{Assay}}, \code{\link{DimReduc}},
#' \code{\link{Graph}}, \code{\link{Neighbor}} objects
#'
#' @param object A \code{\link{Seurat}} object
#' @param slot Name of component object to return
#'
#' @return If \code{slot} is \code{NULL}, the names of all component objects
#' in this \code{Seurat} object. Otherwise, the specific object specified
#'
#' @rdname ObjectAccess
#'
#' @export
#'
#' @concept data-access
#'
#' @examples
#' Assays(object = pbmc_small)
#'
Assays <- function(object, slot = NULL) {
  assays <- FilterObjects(object = object, classes.keep = 'Assay')
  if (is.null(x = slot)) {
    return(assays)
  }
  if (!slot %in% assays) {
    warning(
      "Cannot find an assay of name ",
      slot,
      " in this Seurat object",
      call. = FALSE,
      immediate. = TRUE
    )
  }
  return(slot(object = object, name = 'assays')[[slot]])
}

#' Get cell names grouped by identity class
#'
#' @param object A Seurat object
#' @param idents A vector of identity class levels to limit resulting list to;
#' defaults to all identity class levels
#' @param cells A vector of cells to grouping to
#' @param return.null If no cells are request, return a \code{NULL};
#' by default, throws an error
#'
#' @return A named list where names are identity classes and values are vectors
#' of cells belonging to that class
#'
#' @export
#'
#' @concept data-access
#'
#' @examples
#' CellsByIdentities(object = pbmc_small)
#'
CellsByIdentities <- function(
  object,
  idents = NULL,
  cells = NULL,
  return.null = FALSE
) {
  cells <- cells %||% colnames(x = object)
  cells <- intersect(x = cells, y = colnames(x = object))
  if (length(x = cells) == 0) {
    if (isTRUE(x = return.null)) {
      return(NULL)
    }
    stop("Cannot find cells provided")
  }
  idents <- idents %||% levels(x = object)
  idents <- intersect(x = idents, y = levels(x = object))
  if (length(x = idents) == 0) {
    stop("None of the provided identity class levels were found", call. = FALSE)
  }
  cells.idents <- sapply(
    X = idents,
    FUN = function(i) {
      return(cells[as.vector(x = Idents(object = object)[cells]) == i])
    },
    simplify = FALSE,
    USE.NAMES = TRUE
  )
  if (any(is.na(x = Idents(object = object)[cells]))) {
    cells.idents[["NA"]] <- names(x = which(x = is.na(x = Idents(object = object)[cells])))
  }
  return(cells.idents)
}

#' Get a vector of cell names associated with an image (or set of images)
#'
#' @param object Seurat object
#' @param images Vector of image names
#' @param unlist Return as a single vector of cell names as opposed to a list,
#' named by image name.
#'
#' @return A vector of cell names
#'
#' @concept data-access
#'
#' @examples
#' \dontrun{
#' CellsByImage(object = object, images = "slice1")
#' }
#'
CellsByImage <- function(object, images = NULL, unlist = FALSE) {
  images <- images %||% Images(object = object)
  cells <- sapply(
    X = images,
    FUN = function(x) {
      Cells(x = object[[x]])
    },
    simplify = FALSE,
    USE.NAMES = TRUE
  )
  if (unlist) {
    cells <- unname(obj = unlist(x = cells))
  }
  return(cells)
}

#' Find Sub-objects of a Certain Class
#'
#' Get the names of objects within a \code{Seurat} object that are of a
#' certain class
#'
#' @param object A \code{\link{Seurat}} object
#' @param classes.keep A vector of names of classes to get
#'
#' @return A vector with the names of objects within the \code{Seurat} object
#' that are of class \code{classes.keep}
#'
#' @export
#'
#' @concept utils
#'
#' @examples
#' FilterObjects(pbmc_small)
#'
FilterObjects <- function(object, classes.keep = c('Assay', 'DimReduc')) {
  object <- UpdateSlots(object = object)
  slots <- na.omit(object = Filter(
    f = function(x) {
      sobj <- slot(object = object, name = x)
      return(is.list(x = sobj) && !is.data.frame(x = sobj) && !is.package_version(x = sobj))
    },
    x = slotNames(x = object)
  ))
  slots <- grep(pattern = 'tools', x = slots, value = TRUE, invert = TRUE)
  slots <- grep(pattern = 'misc', x = slots, value = TRUE, invert = TRUE)
  slots.objects <- unlist(
    x = lapply(
      X = slots,
      FUN = function(x) {
        return(names(x = slot(object = object, name = x)))
      }
    ),
    use.names = FALSE
  )
  object.classes <- sapply(
    X = slots.objects,
    FUN = function(i) {
      return(inherits(x = object[[i]], what = classes.keep))
    }
  )
  object.classes <- which(x = object.classes, useNames = TRUE)
  return(names(x = object.classes))
}

#' @rdname ObjectAccess
#' @export
#'
#' @examples
#' Graphs(pbmc_small)
#'
Graphs <- function(object, slot = NULL) {
  graphs <- FilterObjects(object = object, classes.keep = "Graph")
  if (is.null(x = slot)) {
    return(graphs)
  }
  if (!slot %in% graphs) {
    warning(
      "Cannot find a Graph object of name ",
      slot,
      " in this Seurat object",
      call. = FALSE,
      immediate. = TRUE
    )
  }
  return(slot(object = object, name = 'graphs')[[slot]])
}

#' Pull spatial image names
#'
#' List the names of \code{SpatialImage} objects present in a \code{Seurat}
#' object. If \code{assay} is provided, limits search to images associated with
#' that assay
#'
#' @param object A \code{Seurat} object
#' @param assay Name of assay to limit search to
#'
#' @return A list of image names
#'
#' @export
#'
#' @concept data-access
#'
#' @examples
#' \dontrun{
#' Images(object)
#' }
#'
Images <- function(object, assay = NULL) {
  object <- UpdateSlots(object = object)
  images <- names(x = slot(object = object, name = 'images'))
  if (!is.null(x = assay)) {
    assays <- c(assay, DefaultAssay(object = object[[assay]]))
    images <- Filter(
      f = function(x) {
        return(DefaultAssay(object = object[[x]]) %in% assays)
      },
      x = images
    )
  }
  return(images)
}

#' @rdname ObjectAccess
#' @export
#'
Neighbors <- function(object, slot = NULL) {
  neighbors <- FilterObjects(object = object, classes.keep = "Neighbor")
  if (is.null(x = slot)) {
    return(neighbors)
  }
  if (!slot %in% neighbors) {
    warning(
      "Cannot find a Neighbor object of name ",
      slot,
      " in this Seurat object",
      call. = FALSE,
      immediate. = TRUE
    )
  }
  return(slot(object = object, name = 'neighbors')[[slot]])
}

#' @rdname ObjectAccess
#' @export
#'
#' @examples
#' Reductions(object = pbmc_small)
#'
Reductions <- function(object, slot = NULL) {
  reductions <- FilterObjects(object = object, classes.keep = 'DimReduc')
  if (is.null(x = slot)) {
    return(reductions)
  }
  if (!slot %in% reductions) {
    warning(
      "Cannot find a DimReduc of name ",
      slot,
      " in this Seurat object",
      call. = FALSE,
      immediate. = TRUE
    )
  }
  return(slot(object = object, name = 'reductions')[[slot]])
}

#' Rename assays in a \code{Seurat} object
#'
#' @param object A \code{Seurat} object
#' @param ... Named arguments as \code{old.assay = new.assay}
#'
#' @return \code{object} with assays renamed
#'
#' @export
#'
#' @concept seurat
#'
#' @examples
#' RenameAssays(object = pbmc_small, RNA = 'rna')
#'
RenameAssays <- function(object, ...) {
  assay.pairs <- tryCatch(
    expr = as.list(x = ...),
    error = function(e) {
      return(list(...))
    }
  )
  old.assays <- names(x = assay.pairs)
  # Handle missing assays
  missing.assays <- setdiff(x = old.assays, y = Assays(object = object))
  if (length(x = missing.assays) == length(x = old.assays)) {
    stop("None of the assays provided are present in this object", call. = FALSE)
  } else if (length(x = missing.assays)) {
    warning(
      "The following assays could not be found: ",
      paste(missing.assays, collapse = ', '),
      call. = FALSE,
      immediate. = TRUE
    )
  }
  old.assays <- setdiff(x = old.assays, missing.assays)
  assay.pairs <- assay.pairs[old.assays]
  # Check to see that all old assays are named
  if (is.null(x = names(x = assay.pairs)) || any(sapply(X = old.assays, FUN = nchar) < 1)) {
    stop("All arguments must be named with the old assay name", call. = FALSE)
  }
  # Ensure each old assay is going to one new assay
  if (!all(sapply(X = assay.pairs, FUN = length) == 1) || length(x = old.assays) != length(x = unique(x = old.assays))) {
    stop("Can only rename assays to one new name", call. = FALSE)
  }
  # Ensure each new assay is coming from one old assay
  if (length(x = assay.pairs) != length(x = unique(x = assay.pairs))) {
    stop(
      "One or more assays are set to be lost due to duplicate new assay names",
      call. = FALSE
    )
  }
  # Rename assays
  for (old in names(x = assay.pairs)) {
    new <- assay.pairs[[old]]
    # If we aren't actually renaming any
    if (old == new) {
      next
    }
    old.key <- Key(object = object[[old]])
    suppressWarnings(expr = object[[new]] <- object[[old]])
    if (old == DefaultAssay(object = object)) {
      message("Renaming default assay from ", old, " to ", new)
      DefaultAssay(object = object) <- new
    }
    Key(object = object[[new]]) <- old.key
    # change assay used in any dimreduc object
    for (i in Reductions(object = object)) {
      if (DefaultAssay(object = object[[i]]) == old) {
        DefaultAssay(object = object[[i]]) <- new
      }
    }
    object[[old]] <- NULL
  }
  return(object)
}

#' Update old Seurat object to accommodate new features
#'
#' Updates Seurat objects to new structure for storing data/calculations.
#' For Seurat v3 objects, will validate object structure ensuring all keys
#' and feature names are formed properly.
#'
#' @param object Seurat object
#'
#' @return Returns a Seurat object compatible with latest changes
#'
#' @importFrom methods .hasSlot new slot
#' @importFrom utils packageVersion
#'
#' @export
#'
#' @concept seurat
#'
#' @examples
#' \dontrun{
#' updated_seurat_object = UpdateSeuratObject(object = old_seurat_object)
#' }
#'
UpdateSeuratObject <- function(object) {
  if (.hasSlot(object, "version")) {
    if (slot(object = object, name = 'version') >= package_version(x = "2.0.0") && slot(object = object, name = 'version') < package_version(x = '3.0.0')) {
      # Run update
      message("Updating from v2.X to v3.X")
      seurat.version <- packageVersion(pkg = "Seurat")
      new.assay <- UpdateAssay(old.assay = object, assay = "RNA")
      assay.list <- list(new.assay)
      names(x = assay.list) <- "RNA"
      for (i in names(x = object@assay)) {
        assay.list[[i]] <- UpdateAssay(old.assay = object@assay[[i]], assay = i)
      }
      new.dr <- UpdateDimReduction(old.dr = object@dr, assay = "RNA")
      object <- new(
        Class = "Seurat",
        version = seurat.version,
        assays = assay.list,
        active.assay = "RNA",
        project.name = object@project.name,
        misc = object@misc %||% list(),
        active.ident = object@ident,
        reductions = new.dr,
        meta.data = object@meta.data,
        tools = list()
      )
      # Run CalcN
      for (assay in Assays(object = object)) {
        n.calc <- CalcN(object = object[[assay]])
        if (!is.null(x = n.calc)) {
          names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_')
          object[[names(x = n.calc)]] <- n.calc
        }
        to.remove <- c("nGene", "nUMI")
        for (i in to.remove) {
          if (i %in% colnames(x = object[[]])) {
            object[[i]] <- NULL
          }
        }
      }
    }
    if (package_version(x = slot(object = object, name = 'version')) >= package_version(x = "3.0.0")) {
      # Run validation
      message("Validating object structure")
      # Update object slots
      message("Updating object slots")
      object <- UpdateSlots(object = object)
      # Validate object keys
      message("Ensuring keys are in the proper structure")
      for (ko in FilterObjects(object = object)) {
        key <- Key(object = object[[ko]])
        if (!length(x = key) || !nzchar(x = key)) {
          key <- Key(object = ko, quiet = TRUE)
        }
        slot(
          object = slot(object = object, name = FindObject(object, ko))[[ko]],
          name = 'key'
        ) <- UpdateKey(key)
      }
      # Rename assays
      assays <- make.names(names = Assays(object = object))
      names(x = assays) <- Assays(object = object)
      object <- do.call(what = RenameAssays, args = c('object' = object, assays))
      for (obj in FilterObjects(object = object, classes.keep = c('Assay', 'DimReduc', 'Graph'))) {
        suppressWarnings(expr = object[[obj]] <- UpdateSlots(object = object[[obj]]))
      }
      for (cmd in Command(object = object)) {
        slot(object = object, name = 'commands')[[cmd]] <- UpdateSlots(
          object = Command(object = object, command = cmd)
        )
      }
      # Check feature names
      message("Ensuring feature names don't have underscores or pipes")
      for (assay.name in FilterObjects(object = object, classes.keep = 'Assay')) {
        assay <- object[[assay.name]]
        for (slot in c('counts', 'data', 'scale.data')) {
          if (!IsMatrixEmpty(x = slot(object = assay, name = slot))) {
            rownames(x = slot(object = assay, name = slot)) <- gsub(
              pattern = '_',
              replacement = '-',
              x = rownames(x = slot(object = assay, name = slot))
            )
            rownames(x = slot(object = assay, name = slot)) <- gsub(
              pattern = '|',
              replacement = '-',
              x = rownames(x = slot(object = assay, name = slot)),
              fixed = TRUE
            )
          }
        }
        VariableFeatures(object = assay) <- gsub(
          pattern = '_',
          replacement = '-',
          x = VariableFeatures(object = assay)
        )
        VariableFeatures(object = assay) <- gsub(
          pattern = '|',
          replacement = '-',
          x = VariableFeatures(object = assay),
          fixed = TRUE
        )
        rownames(x = slot(object = assay, name = "meta.features")) <-  gsub(
          pattern = '_',
          replacement = '-',
          x = rownames(x = assay[[]])
        )
        rownames(x = slot(object = assay, name = "meta.features")) <-  gsub(
          pattern = '|',
          replacement = '-',
          x = rownames(x = assay[[]]),
          fixed = TRUE
        )
        object[[assay.name]] <- assay
      }
      for (reduc.name in FilterObjects(object = object, classes.keep = 'DimReduc')) {
        reduc <- object[[reduc.name]]
        for (slot in c('feature.loadings', 'feature.loadings.projected')) {
          if (!IsMatrixEmpty(x = slot(object = reduc, name = slot))) {
            rownames(x = slot(object = reduc, name = slot)) <- gsub(
              pattern = '_',
              replacement = '-',
              x = rownames(x = slot(object = reduc, name = slot))
            )
            rownames(x = slot(object = reduc, name = slot)) <- gsub(
              pattern = '_',
              replacement = '-',
              x = rownames(x = slot(object = reduc, name = slot)),
              fixed = TRUE
            )
          }
        }
        object[[reduc.name]] <- reduc
      }
    }
    if (package_version(x = slot(object = object, name = 'version')) <= package_version(x = '3.1.1')) {
      # Update Assays, DimReducs, and Graphs
      for (x in names(x = object)) {
        message("Updating slots in ", x)
        xobj <- object[[x]]
        xobj <- UpdateSlots(object = xobj)
        if (inherits(x = xobj, what = 'DimReduc')) {
          if (any(sapply(X = c('tsne', 'umap'), FUN = grepl, x = tolower(x = x)))) {
            message("Setting ", x, " DimReduc to global")
            slot(object = xobj, name = 'global') <- TRUE
          }
        } else if (inherits(x = xobj, what = 'Graph')) {
          graph.assay <- unlist(x = strsplit(x = x, split = '_'))[1]
          if (graph.assay %in% Assays(object = object)) {
            message("Setting default assay of ", x, " to ", graph.assay)
            DefaultAssay(object = xobj) <- graph.assay
          }
        }
        object[[x]] <- xobj
      }
      # Update SeuratCommands
      for (cmd in Command(object = object)) {
        cobj <- Command(object = object, command = cmd)
        cobj <- UpdateSlots(object = cobj)
        cmd.assay <- unlist(x = strsplit(x = cmd, split = '\\.'))
        cmd.assay <- cmd.assay[length(x = cmd.assay)]
        cmd.assay <- if (cmd.assay %in% Assays(object = object)) {
          cmd.assay
        } else if (cmd.assay %in% Reductions(object = object)) {
          DefaultAssay(object = object[[cmd.assay]])
        } else {
          NULL
        }
        if (is.null(x = cmd.assay)) {
          message("No assay information could be found for ", cmd)
        } else {
          message("Setting assay used for ", cmd, " to ", cmd.assay)
        }
        slot(object = cobj, name = 'assay.used') <- cmd.assay
        object[[cmd]] <- cobj
      }
      # Update object version
      slot(object = object, name = 'version') <- packageVersion(pkg = 'Seurat')
    }
    object <- UpdateSlots(object = object)
    if (package_version(x = slot(object = object, name = 'version')) <= package_version(x = '4.0.0')) {
      # Transfer the object to the SeuratObject namespace
      object <- UpdateClassPkg(
        object = object,
        from = 'Seurat',
        to = 'SeuratObject'
      )
      slot(object = object, name = 'version') <- max(
        package_version(x = '4.0.0'),
        packageVersion(pkg = 'SeuratObject')
      )
    }
    message("Object representation is consistent with the most current Seurat version")
    return(object)
  }
  stop(
    "We are unable to convert Seurat objects less than version 2.X to version 3.X\n",
    'Please use devtools::install_version to install Seurat v2.3.4 and update your object to a 2.X object',
    call. = FALSE
  )
}

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for Seurat-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#' @rdname AddMetaData
#' @export
#' @method AddMetaData Seurat
#'
AddMetaData.Seurat <- .AddMetaData

#' @param command Name of the command to pull, pass \code{NULL} to get the
#' names of all commands run
#' @param value Name of the parameter to pull the value for
#'
#' @rdname Command
#' @export
#' @method Command Seurat
#'
Command.Seurat <- function(object, command = NULL, value = NULL, ...) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  commands <- slot(object = object, name = "commands")
  if (is.null(x = command)) {
    return(names(x = commands))
  }
  if (is.null(x = commands[[command]])) {
    stop(command, " has not been run or is not a valid command.")
  }
  command <- commands[[command]]
  if (is.null(x = value)) {
    return(command)
  }
  params <- slot(object = command, name = "params")
  if (!value %in% names(x = params)) {
    stop(value, " is not a valid parameter for ", slot(object = command, name = "name"))
  }
  return(params[[value]])
}

#' @param row.names When \code{counts} is a \code{data.frame} or
#' \code{data.frame}-derived object: an optional vector of feature names to be
#' used
#'
#' @rdname CreateSeuratObject
#' @method CreateSeuratObject default
#' @export
#'
CreateSeuratObject.default <- function(
  counts,
  project = 'SeuratProject',
  assay = 'RNA',
  names.field = 1,
  names.delim = '_',
  meta.data = NULL,
  min.cells = 0,
  min.features = 0,
  row.names = NULL,
  ...
) {
  if (!is.null(x = meta.data)) {
    if (!all(rownames(x = meta.data) %in% colnames(x = counts))) {
      warning("Some cells in meta.data not present in provided counts matrix")
    }
  }
  assay.data <- CreateAssayObject(
    counts = counts,
    min.cells = min.cells,
    min.features = min.features,
    row.names = row.names
  )
  if (!is.null(x = meta.data)) {
    common.cells <- intersect(
      x = rownames(x = meta.data), y = colnames(x = assay.data)
    )
    meta.data <- meta.data[common.cells, , drop = FALSE]
  }
  Key(object = assay.data) <- suppressWarnings(expr = UpdateKey(key = tolower(
    x = assay
  )))
  return(CreateSeuratObject(
    counts = assay.data,
    project = project,
    assay = assay,
    names.field = names.field,
    names.delim = names.delim,
    meta.data = meta.data,
    ...
  ))
}

#' @rdname CreateSeuratObject
#' @method CreateSeuratObject Assay
#' @export
#'
CreateSeuratObject.Assay <- function(
  counts,
  project = 'SeuratProject',
  assay = 'RNA',
  names.field = 1,
  names.delim = '_',
  meta.data = NULL,
  ...
) {
  if (!is.null(x = meta.data)) {
    if (is.null(x = rownames(x = meta.data))) {
      stop("Row names not set in metadata. Please ensure that rownames of metadata match column names of data matrix")
    }
    if (length(x = setdiff(x = rownames(x = meta.data), y = colnames(x = counts)))) {
      warning("Some cells in meta.data not present in provided counts matrix.")
      meta.data <- meta.data[intersect(x = rownames(x = meta.data), y = colnames(x = counts)), , drop = FALSE]
    }
    if (is.data.frame(x = meta.data)) {
      new.meta.data <- data.frame(row.names = colnames(x = counts))
      for (ii in 1:ncol(x = meta.data)) {
        new.meta.data[rownames(x = meta.data), colnames(x = meta.data)[ii]] <- meta.data[, ii, drop = FALSE]
      }
      meta.data <- new.meta.data
    }
  }
  # Check assay key
  if (!length(x = Key(object = counts)) || !nchar(x = Key(object = counts))) {
    Key(object = counts) <- UpdateKey(key = tolower(x = assay))
  }
  assay.list <- list(counts)
  names(x = assay.list) <- assay
  # Set idents
  idents <- factor(x = unlist(x = lapply(
    X = colnames(x = counts),
    FUN = ExtractField,
    field = names.field,
    delim = names.delim
  )))
  if (any(is.na(x = idents))) {
    warning(
      "Input parameters result in NA values for initial cell identities. Setting all initial idents to the project name",
      call. = FALSE,
      immediate. = TRUE
    )
  }
  # if there are more than 100 idents, set all idents to ... name
  ident.levels <- length(x = unique(x = idents))
  if (ident.levels > 100 || ident.levels == 0 || ident.levels == length(x = idents)) {
    idents <- rep.int(x = factor(x = project), times = ncol(x = counts))
  }
  names(x = idents) <- colnames(x = counts)
  object <- new(
    Class = 'Seurat',
    assays = assay.list,
    meta.data = data.frame(row.names = colnames(x = counts)),
    active.assay = assay,
    active.ident = idents,
    project.name = project,
    version = packageVersion(pkg = 'SeuratObject')
  )
  object[['orig.ident']] <- idents
  # Calculate nCount and nFeature
  n.calc <- CalcN(object = counts)
  if (!is.null(x = n.calc)) {
    names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_')
    object[[names(x = n.calc)]] <- n.calc
  }
  # Add metadata
  if (!is.null(x = meta.data)) {
    object <- AddMetaData(object = object, metadata = meta.data)
  }
  return(object)
}

#' @rdname DefaultAssay
#' @export
#' @method DefaultAssay Seurat
#'
#' @examples
#' # Get current default assay
#' DefaultAssay(object = pbmc_small)
#'
DefaultAssay.Seurat <- function(object, ...) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  return(slot(object = object, name = 'active.assay'))
}

#' @rdname DefaultAssay
#' @export
#' @method DefaultAssay<- Seurat
#'
#' @examples
#' # Create dummy new assay to demo switching default assays
#' new.assay <- pbmc_small[["RNA"]]
#' Key(object = new.assay) <- "RNA2_"
#' pbmc_small[["RNA2"]] <- new.assay
#' # switch default assay to RNA2
#' DefaultAssay(object = pbmc_small) <- "RNA2"
#' DefaultAssay(object = pbmc_small)
#'
"DefaultAssay<-.Seurat" <- function(object, ..., value) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  if (!value %in% names(x = slot(object = object, name = 'assays'))) {
    stop("Cannot find assay ", value)
  }
  slot(object = object, name = 'active.assay') <- value
  return(object)
}

#' @param assay Name of assay to get or set default \code{\link{FOV}} for;
#' pass \code{NA} to get or set the global default \code{\link{FOV}}
#'
#' @rdname DefaultFOV
#' @method DefaultFOV Seurat
#' @export
#'
DefaultFOV.Seurat <- function(object, assay = NULL, ...) {
  assay <- assay[1L] %||% DefaultAssay(object = object)
  fovs <- FilterObjects(object = object, classes.keep = 'FOV')
  if (is.na(x = assay)) {
    return(fovs[1L])
  }
  assay <- match.arg(arg = assay, choices = Assays(object = object))
  assay.fovs <- Filter(
    f = function(x) {
      return(DefaultAssay(object = object[[x]]) == assay)
    },
    x = fovs
  )
  if (!length(x = assay.fovs)) {
    warning(
      "No FOV associated with assay '",
      assay,
      "', using global default FOV",
      call. = FALSE,
      immediate. = TRUE
    )
    assay.fovs <- fovs[1L]
  }
  return(assay.fovs[1L])
}

#' @rdname DefaultFOV
#' @method DefaultFOV<- Seurat
#' @export
#'
"DefaultFOV<-.Seurat" <- function(object, assay = NA, ..., value) {
  assay <- assay[1L] %||% DefaultAssay(object = object)
  fovs <- FilterObjects(object = object, classes.keep = 'FOV')
  value <- match.arg(arg = value, choices = fovs)
  if (!is.na(x = assay)) {
    assay <- match.arg(arg = assay, choices = Assays(object = object))
    if (DefaultAssay(object = object[[value]]) != assay) {
      warning(
        "FOV '",
        value,
        "' currently associated with assay '",
        DefaultAssay(object = object[[value]]),
        "', changing to '",
        assay,
        "'",
        call. = FALSE,
        immediate. = TRUE
      )
      DefaultAssay(object = object[[value]]) <- assay
    }
    fovs <- Filter(
      f = function(x) {
        return(DefaultAssay(object = object[[x]]) == assay)
      },
      x = fovs
    )
  }
  fidx <- which(x = fovs == value)
  forder <- c(fidx, setdiff(x = seq_along(along.with = fovs), y = fidx))
  fovs <- fovs[forder]
  iidx <- seq_along(along.with = Images(object = object))
  midx <- MatchCells(new = Images(object = object), orig = fovs, ordered = TRUE)
  iidx[sort(x = midx)] <- midx
  slot(object = object, name = 'images') <- slot(
    object = object,
    name = 'images'
  )[iidx]
  return(object)
}

#' @param reduction Name of reduction to pull cell embeddings for
#'
#' @rdname Embeddings
#' @export
#' @method Embeddings Seurat
#'
#' @examples
#' # Get the embeddings from a specific DimReduc in a Seurat object
#' Embeddings(object = pbmc_small, reduction = "pca")[1:5, 1:5]
#'
Embeddings.Seurat <- function(object, reduction = 'pca', ...) {
  object <- UpdateSlots(object = object)
  return(Embeddings(object = object[[reduction]], ...))
}

#' @param vars List of all variables to fetch, use keyword \dQuote{ident} to
#' pull identity classes
#' @param cells Cells to collect data for (default is all cells)
#' @param slot Slot to pull feature data for
#'
#' @return A data frame with cells as rows and cellular data as columns
#'
#' @rdname FetchData
#' @method FetchData Seurat
#' @export
#'
#' @concept data-access
#'
#' @examples
#' pc1 <- FetchData(object = pbmc_small, vars = 'PC_1')
#' head(x = pc1)
#' head(x = FetchData(object = pbmc_small, vars = c('groups', 'ident')))
#'
FetchData.Seurat <- function(object, vars, cells = NULL, slot = 'data', ...) {
  object <- UpdateSlots(object = object)
  cells <- cells %||% colnames(x = object)
  if (is.numeric(x = cells)) {
    cells <- colnames(x = object)[cells]
  }
  if (is.null(x = vars)) {
    df <- EmptyDF(n = length(x = cells))
    rownames(x = df) <- cells
    return(df)
  }
  # Get a list of all objects to search through and their keys
  object.keys <- Key(object = object)
  # Find all vars that are keyed
  keyed.vars <- lapply(
    X = object.keys,
    FUN = function(key) {
      if (length(x = key) == 0 || nchar(x = key) == 0) {
        return(integer(length = 0L))
      }
      return(grep(pattern = paste0('^', key), x = vars))
    }
  )
  keyed.vars <- Filter(f = length, x = keyed.vars)
  ret.spatial2 <- vapply(
    X = names(x = keyed.vars),
    FUN = function(x) {
      return(inherits(x = object[[x]], what = 'FOV'))
    },
    FUN.VALUE = logical(length = 1L)
  )
  if (any(ret.spatial2) && !all(ret.spatial2)) {
    warning(
      "Data returned from spatial coordinates are incompatible with other data, returning only spatial coordinates",
      call. = FALSE,
      immediate. = TRUE
    )
    keyed.vars <- keyed.vars[ret.spatial2]
  }
  data.fetched <- lapply(
    X = names(x = keyed.vars),
    FUN = function(x) {
      vars.use <- vars[keyed.vars[[x]]]
      key.use <- object.keys[x]
      data.return <- if (inherits(x = object[[x]], what = 'DimReduc')) {
        tryCatch(
          expr = FetchData(object = object[[x]], vars = vars.use, cells = cells),
          error = function(e) {
            return(NULL)
          }
        )
      } else if (inherits(x = object[[x]], what = 'Assay')) {
        vars.use <- gsub(pattern = paste0('^', key.use), replacement = '', x = vars.use)
        data.assay <- GetAssayData(
          object = object,
          slot = slot,
          assay = x
        )
        vars.use <- vars.use[vars.use %in% rownames(x = data.assay)]
        data.vars <- t(x = as.matrix(data.assay[vars.use, cells, drop = FALSE]))
        if (ncol(data.vars) > 0) {
          colnames(x = data.vars) <- paste0(key.use, vars.use)
        }
        data.vars
      } else if (inherits(x = object[[x]], what = 'FOV')) {
        vars.use <- gsub(pattern = paste0('^', key.use), replacement = '', x = vars.use)
        FetchData(object = object[[x]], vars = vars.use, cells = cells)
      } else if (inherits(x = object[[x]], what = 'SpatialImage')) {
        vars.unkeyed <- gsub(pattern = paste0('^', key.use), replacement = '', x = vars.use)
        names(x = vars.use) <- vars.unkeyed
        coords <- GetTissueCoordinates(object = object[[x]])[cells, vars.unkeyed, drop = FALSE]
        colnames(x = coords) <- vars.use[colnames(x = coords)]
        coords
      }
      data.return <- as.list(x = as.data.frame(x = data.return))
      return(data.return)
    }
  )
  data.fetched <- unlist(x = data.fetched, recursive = FALSE)
  if (any(ret.spatial2)) {
    return(as.data.frame(x = data.fetched))
  }
  # Pull vars from object metadata
  meta.vars <- vars[vars %in% colnames(x = object[[]]) & !(vars %in% names(x = data.fetched))]
  data.fetched <- c(data.fetched, object[[meta.vars]][cells, , drop = FALSE])
  meta.default <- meta.vars[meta.vars %in% rownames(x = GetAssayData(object = object, slot = slot))]
  if (length(x = meta.default)) {
    warning(
      "The following variables were found in both object metadata and the default assay: ",
      paste0(meta.default, collapse = ", "),
      "\nReturning metadata; if you want the feature, please use the assay's key (eg. ",
      paste0(Key(object = object[[DefaultAssay(object = object)]]), meta.default[1]),
      ")",
      call. = FALSE
    )
  }
  # Pull vars from the default assay
  default.vars <- vars[vars %in% rownames(x = GetAssayData(object = object, slot = slot)) & !(vars %in% names(x = data.fetched))]
  data.fetched <- c(
    data.fetched,
    tryCatch(
      expr = as.data.frame(x = t(x = as.matrix(x = GetAssayData(
        object = object,
        slot = slot
      )[default.vars, cells, drop = FALSE]))),
      error = function(...) {
        return(NULL)
      }
    )
  )
  # Pull identities
  if ('ident' %in% vars && !'ident' %in% colnames(x = object[[]])) {
    data.fetched[['ident']] <- Idents(object = object)[cells]
  }
  # Try to find ambiguous vars
  fetched <- names(x = data.fetched)
  vars.missing <- setdiff(x = vars, y = fetched)
  if (length(x = vars.missing) > 0) {
    # Search for vars in alternative assays
    vars.alt <- vector(mode = 'list', length = length(x = vars.missing))
    names(x = vars.alt) <- vars.missing
    for (assay in FilterObjects(object = object, classes.keep = 'Assay')) {
      vars.assay <- Filter(
        f = function(x) {
          features.assay <- rownames(x = GetAssayData(
            object = object,
            assay = assay,
            slot = slot
          ))
          return(x %in% features.assay)
        },
        x = vars.missing
      )
      for (var in vars.assay) {
        vars.alt[[var]] <- append(x = vars.alt[[var]], values = assay)
      }
    }
    # Vars found in multiple alternative assays are truly ambiguous, will not pull
    vars.many <- names(x = Filter(
      f = function(x) {
        return(length(x = x) > 1)
      },
      x = vars.alt
    ))
    if (length(x = vars.many) > 0) {
      warning(
        "Found the following features in more than one assay, excluding the default. We will not include these in the final data frame: ",
        paste(vars.many, collapse = ', '),
        call. = FALSE,
        immediate. = TRUE
      )
    }
    vars.missing <- names(x = Filter(
      f = function(x) {
        return(length(x = x) != 1)
      },
      x = vars.alt
    ))
    # Pull vars found in only one alternative assay
    # Key this var to highlight that it was found in an alternate assay
    vars.alt <- Filter(
      f = function(x) {
        return(length(x = x) == 1)
      },
      x = vars.alt
    )
    for (var in names(x = vars.alt)) {
      assay <- vars.alt[[var]]
      warning(
        'Could not find ',
        var,
        ' in the default search locations, found in ',
        assay,
        ' assay instead',
        immediate. = TRUE,
        call. = FALSE
      )
      keyed.var <- paste0(Key(object = object[[assay]]), var)
      data.fetched[[keyed.var]] <- as.vector(
        x = GetAssayData(object = object, assay = assay, slot = slot)[var, cells]
      )
      vars <- sub(
        pattern = paste0('^', var, '$'),
        replacement = keyed.var,
        x = vars
      )
    }
    fetched <- names(x = data.fetched)
  }
  # Name the vars not found in a warning (or error if no vars found)
  m2 <- if (length(x = vars.missing) > 10) {
    paste0(' (10 out of ', length(x = vars.missing), ' shown)')
  } else {
    ''
  }
  if (length(x = vars.missing) == length(x = vars)) {
    stop(
      "None of the requested variables were found",
      m2,
      ': ',
      paste(head(x = vars.missing, n = 10L), collapse = ', ')
    )
  } else if (length(x = vars.missing) > 0) {
    warning(
      "The following requested variables were not found",
      m2,
      ': ',
      paste(head(x = vars.missing, n = 10L), collapse = ', ')
    )
  }
  # Assembled fetched vars in a data frame
  data.fetched <- as.data.frame(
    x = data.fetched,
    row.names = cells,
    stringsAsFactors = FALSE
  )
  data.order <- na.omit(object = pmatch(
    x = vars,
    table = fetched
  ))
  if (length(x = data.order) > 1) {
    data.fetched <- data.fetched[, data.order]
  }
  colnames(x = data.fetched) <- vars[vars %in% fetched]
  return(data.fetched)
}

#' @param assay Specific assay to get data from or set data for; defaults to
#' the \link[SeuratObject:DefaultAssay]{default assay}
#'
#' @rdname AssayData
#' @export
#' @method GetAssayData Seurat
#'
#' @order 3
#'
#' @examples
#' # Get assay data from the default assay in a Seurat object
#' GetAssayData(object = pbmc_small, slot = "data")[1:5,1:5]
#'
GetAssayData.Seurat <- function(object, slot = 'data', assay = NULL, ...) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  assay <- assay %||% DefaultAssay(object = object)
  if (!assay %in% Assays(object = object)) {
    stop("'", assay, "' is not an assay", call. = FALSE)
  }
  return(GetAssayData(
    object = object[[assay]],
    slot = slot
  ))
}

#' @param image Name of \code{SpatialImage} object to pull image data for; if
#' \code{NULL}, will attempt to select an image automatically
#'
#' @rdname GetImage
#' @method GetImage Seurat
#' @export
#'
GetImage.Seurat <- function(
  object,
  mode = c('grob', 'raster', 'plotly', 'raw'),
  image = NULL,
  ...
) {
  mode <- match.arg(arg = mode)
  image <- image %||% DefaultImage(object = object)
  if (is.null(x = image)) {
    stop("No images present in this Seurat object", call. = FALSE)
  }
  return(GetImage(object = object[[image]], mode = mode, ...))
}

#' @param image Name of \code{SpatialImage} object to get coordinates for; if
#' \code{NULL}, will attempt to select an image automatically
#'
#' @rdname GetTissueCoordinates
#' @method GetTissueCoordinates Seurat
#' @export
#'
GetTissueCoordinates.Seurat <- function(object, image = NULL, ...) {
  image <- image %||% DefaultImage(object = object)
  if (is.null(x = image)) {
    stop("No images present in this Seurat object", call. = FALSE)
  }
  return(GetTissueCoordinates(object = object[[image]], ...))
}

#' @param assay Name of assay to pull highly variable feature information for
#'
#' @importFrom tools file_path_sans_ext
#'
#' @rdname VariableFeatures
#' @export
#' @method HVFInfo Seurat
#'
#' @order 6
#'
#' @examples
#' # Get the HVF info from a specific Assay in a Seurat object
#' HVFInfo(object = pbmc_small, assay = "RNA")[1:5, ]
#'
HVFInfo.Seurat <- function(
  object,
  selection.method = NULL,
  status = FALSE,
  assay = NULL,
  ...
) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  assay <- assay %||% DefaultAssay(object = object)
  if (is.null(x = selection.method)) {
    cmds <- apply(
      X = expand.grid(
        c('FindVariableFeatures', 'SCTransform'),
        FilterObjects(object = object, classes.keep = 'Assay')
      ),
      MARGIN = 1,
      FUN = paste,
      collapse = '.'
    )
    find.command <- Command(object = object)[Command(object = object) %in% cmds]
    if (length(x = find.command) < 1) {
      stop(
        "Please run either 'FindVariableFeatures' or 'SCTransform'",
        call. = FALSE
      )
    }
    find.command <- find.command[length(x = find.command)]
    test.command <- paste(file_path_sans_ext(x = find.command), assay, sep = '.')
    find.command <- ifelse(
      test = test.command %in% Command(object = object),
      yes = test.command,
      no = find.command
    )
    selection.method <- switch(
      EXPR = file_path_sans_ext(x = find.command),
      'FindVariableFeatures' = Command(
        object = object,
        command = find.command,
        value = 'selection.method'
      ),
      'SCTransform' = 'sct',
      stop("Unknown command for finding variable features: '", find.command, "'", call. = FALSE)
    )
  }
  return(HVFInfo(
    object = object[[assay]],
    selection.method = selection.method,
    status = status
  ))
}

#' @rdname Idents
#' @export
#' @method Idents Seurat
#'
Idents.Seurat <- function(object, ...) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  return(slot(object = object, name = 'active.ident'))
}

#' @param cells Set cell identities for specific cells
#' @param drop Drop unused levels
#'
#' @rdname Idents
#' @export
#' @method Idents<- Seurat
#'
"Idents<-.Seurat" <- function(object, cells = NULL, drop = FALSE, ..., value) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  cells <- cells %||% colnames(x = object)
  if (is.numeric(x = cells)) {
    cells <- colnames(x = object)[cells]
  }
  cells <- intersect(x = cells, y = colnames(x = object))
  cells <- match(x = cells, table = colnames(x = object))
  if (length(x = cells) == 0) {
    warning("Cannot find cells provided")
    return(object)
  }
  idents.new <- if (length(x = value) == 1 && value %in% colnames(x = object[[]])) {
    unlist(x = object[[value]], use.names = FALSE)[cells]
  } else {
    if (is.list(x = value)) {
      value <- unlist(x = value, use.names = FALSE)
    }
    rep_len(x = value, length.out = length(x = cells))
  }
  new.levels <- if (is.factor(x = idents.new)) {
    levels(x = idents.new)
  } else {
    unique(x = idents.new)
  }
  old.levels <- levels(x = object)
  levels <- c(new.levels, old.levels)
  idents.new <- as.vector(x = idents.new)
  idents <- as.vector(x = Idents(object = object))
  idents[cells] <- idents.new
  idents[is.na(x = idents)] <- 'NA'
  levels <- intersect(x = levels, y = unique(x = idents))
  names(x = idents) <- colnames(x = object)
  missing.cells <- which(x = is.na(x = names(x = idents)))
  if (length(x = missing.cells) > 0) {
    idents <- idents[-missing.cells]
  }
  idents <- factor(x = idents, levels = levels)
  slot(object = object, name = 'active.ident') <- idents
  if (drop) {
    object <- droplevels(x = object)
  }
  return(object)
}

#' @rdname Key
#' @export
#' @method Key Seurat
#'
#' @examples
#' # Show all keys associated with a Seurat object
#' Key(object = pbmc_small)
#' Keys(object = pbmc_small)
#'
Key.Seurat <- function(object, ...) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  keyed.objects <- FilterObjects(
    object = object,
    classes.keep = c('Assay', 'DimReduc', 'SpatialImage')
  )
  keys <- vapply(
    X = keyed.objects,
    FUN = function(x) {
      return(Key(object = object[[x]]))
    },
    FUN.VALUE = character(length = 1L),
    USE.NAMES = FALSE
  )
  names(x = keys) <- keyed.objects
  return(keys)
}

#' @rdname Key
#' @export
#' @method Keys Seurat
#'
Keys.Seurat <- Key.Seurat

#' @param reduction Name of reduction to pull feature loadings for
#'
#' @rdname Loadings
#' @export
#' @method Loadings Seurat
#'
#' @examples
#' # Get the feature loadings for a specified DimReduc in a Seurat object
#' Loadings(object = pbmc_small, reduction = "pca")[1:5,1:5]
#'
Loadings.Seurat <- function(object, reduction = 'pca', projected = FALSE, ...) {
  object <- UpdateSlots(object = object)
  return(Loadings(object = object[[reduction]], projected = projected, ...))
}

#' @rdname Misc
#' @export
#' @method Misc Seurat
#'
#' @examples
#' # Get the misc info
#' Misc(object = pbmc_small, slot = "example")
#'
Misc.Seurat <- .Misc

#' @rdname Misc
#' @export
#' @method Misc<- Seurat
#'
#' @examples
#'# Add misc info
#' Misc(object = pbmc_small, slot = "example") <- "testing_misc"
#'
"Misc<-.Seurat" <- `.Misc<-`

#' @rdname Project
#' @export
#' @method Project Seurat
#'
Project.Seurat <- function(object, ...) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  return(slot(object = object, name = 'project.name'))
}

#' @rdname Project
#' @export
#' @method Project<- Seurat
#'
"Project<-.Seurat" <- function(object, ..., value) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  slot(object = object, name = 'project.name') <- as.character(x = value)
  return(object)
}

#' @param reverse Reverse ordering
#' @param afxn Function to evaluate each identity class based on; default is
#' \code{\link[base]{mean}}
#' @param reorder.numeric Rename all identity classes to be increasing numbers
#' starting from 1 (default is FALSE)
#'
#' @rdname Idents
#' @export
#' @method ReorderIdent Seurat
#'
ReorderIdent.Seurat <- function(
  object,
  var,
  reverse = FALSE,
  afxn = mean,
  reorder.numeric = FALSE,
  ...
) {
  object <- UpdateSlots(object = object)
  data.use <- FetchData(object = object, vars = var, ...)[, 1]
  rfxn <- ifelse(
    test = reverse,
    yes = function(x) {
      return(max(x) + 1 - x)
    },
    no = identity
  )
  new.levels <- names(x = rfxn(x = sort(x = tapply(
    X = data.use,
    INDEX = Idents(object = object),
    FUN = afxn
  ))))
  new.idents <- factor(
    x = Idents(object = object),
    levels = new.levels,
    ordered = TRUE
  )
  if (reorder.numeric) {
    new.idents <- rfxn(x = rank(x = tapply(
      X = data.use,
      INDEX = as.numeric(x = new.idents),
      FUN = mean
    )))[as.numeric(x = new.idents)]
    new.idents <- factor(
      x = new.idents,
      levels = 1:length(x = new.idents),
      ordered = TRUE
    )
  }
  Idents(object = object) <- new.idents
  return(object)
}

#' @param for.merge Only rename slots needed for merging Seurat objects.
#' Currently only renames the raw.data and meta.data slots.
#' @param add.cell.id prefix to add cell names
#'
#' @details
#' If \code{add.cell.id} is set a prefix is added to existing cell names. If
#' \code{new.names} is set these will be used to replace existing names.
#'
#' @rdname RenameCells
#' @export
#' @method RenameCells Seurat
#'
#' @examples
#' # Rename cells in a Seurat object
#' head(x = colnames(x = pbmc_small))
#' pbmc_small <- RenameCells(object = pbmc_small, add.cell.id = "A")
#' head(x = colnames(x = pbmc_small))
#'
RenameCells.Seurat <- function(
  object,
  add.cell.id = NULL,
  new.names = NULL,
  for.merge = FALSE,
  ...
) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  if (missing(x = add.cell.id) && missing(x = new.names)) {
    stop("One of 'add.cell.id' and 'new.names' must be set")
  }
  if (!missing(x = add.cell.id) && !missing(x = new.names)) {
    stop("Only one of 'add.cell.id' and 'new.names' may be set")
  }
  if (!missing(x = add.cell.id)) {
    new.cell.names <- paste(add.cell.id, colnames(x = object), sep = "_")
  } else {
    if (length(x = new.names) == ncol(x = object)) {
      new.cell.names <- new.names
    } else {
      stop(
        "the length of 'new.names' (",
        length(x = new.names),
        ") must be the same as the number of cells (",
        ncol(x = object),
        ")"
      )
    }
  }
  old.names <- colnames(x = object)
  # rename in the assay objects
  assays <- FilterObjects(object = object, classes.keep = 'Assay')
  for (assay in assays) {
    slot(object = object, name = "assays")[[assay]] <- RenameCells(
      object = object[[assay]],
      new.names = new.cell.names
    )
  }
  # rename in the DimReduc objects
  dimreducs <- FilterObjects(object = object, classes.keep = 'DimReduc')
  for (dr in dimreducs) {
    object[[dr]] <- RenameCells(
      object = object[[dr]],
      new.names = new.cell.names
    )
  }
  # rename the active.idents
  old.ids <- Idents(object = object)
  names(x = old.ids) <- new.cell.names
  Idents(object = object) <- old.ids
  # rename the cell-level metadata
  old.meta.data <- object[[]]
  rownames(x = old.meta.data) <- new.cell.names
  slot(object = object, name = "meta.data") <- old.meta.data
  # rename the graphs
  graphs <- FilterObjects(object = object, classes.keep = "Graph")
  for (g in graphs) {
    rownames(x = object[[g]]) <- colnames(x = object[[g]]) <- new.cell.names
  }
  # Rename the images
  names(x = new.cell.names) <- old.names
  for (i in Images(object = object)) {
    object[[i]] <- RenameCells(
      object = object[[i]],
      new.names = unname(
        obj = new.cell.names[Cells(x = object[[i]], boundary = NA)]
      )
    )
  }
  # Rename the Neighbor
  for (i in Neighbors(object = object)) {
    object[[i]] <- RenameCells(
      object = object[[i]],
      old.names = old.names,
      new.names = new.cell.names
    )
  }
  return(object)
}

#' @rdname Idents
#' @export
#' @method RenameIdents Seurat
#'
RenameIdents.Seurat <- function(object, ...) {
  ident.pairs <- tryCatch(
    expr = as.list(x = ...),
    error = function(e) {
      return(list(...))
    }
  )
  if (is.null(x = names(x = ident.pairs))) {
    stop("All arguments must be named with the old identity class")
  }
  if (!all(sapply(X = ident.pairs, FUN = length) == 1)) {
    stop("Can only rename identity classes to one value")
  }
  if (!any(names(x = ident.pairs) %in% levels(x = object))) {
    stop("Cannot find any of the provided identities")
  }
  cells.idents <- CellsByIdentities(object = object)
  for (i in rev(x = names(x = ident.pairs))) {
    if (!i %in% names(x = cells.idents)) {
      warning("Cannot find identity ", i, call. = FALSE, immediate. = TRUE)
      next
    }
    Idents(object = object, cells = cells.idents[[i]]) <- ident.pairs[[i]]
  }
  return(object)
}

#' @rdname AssayData
#' @export
#' @method SetAssayData Seurat
#'
#' @order 4
#'
#' @examples
#' # Set an Assay slot through the Seurat object
#' count.data <- GetAssayData(object = pbmc_small[["RNA"]], slot = "counts")
#' count.data <- as.matrix(x = count.data + 1)
#' new.seurat.object <- SetAssayData(
#'     object = pbmc_small,
#'     slot = "counts",
#'     new.data = count.data,
#'     assay = "RNA"
#' )
#'
SetAssayData.Seurat <- function(
  object,
  slot = 'data',
  new.data,
  assay = NULL,
  ...
) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  assay <- assay %||% DefaultAssay(object = object)
  object[[assay]] <- SetAssayData(
    object = object[[assay]],
    slot = slot,
    new.data = new.data,
    ...
  )
  return(object)
}

#' @rdname Idents
#' @export
#' @method SetIdent Seurat
#'
SetIdent.Seurat <- function(object, cells = NULL, value, ...) {
  #message(
  #  'With Seurat 3.X, setting identity classes can be done as follows:\n',
  #  'Idents(object = ',
  #  deparse(expr = substitute(expr = object)),
  #  if (!is.null(x = cells)) {
  #    paste0(', cells = ', deparse(expr = substitute(expr = cells)))
  #  },
  #  ') <- ',
  #  deparse(expr = substitute(expr = value))
  #)
  CheckDots(...)
  object <- UpdateSlots(object = object)
  Idents(object = object, cells = cells) <- value
  return(object)
}

#' @rdname VariableFeatures
#' @export
#' @method SpatiallyVariableFeatures Seurat
#'
#' @order 10
#'
SpatiallyVariableFeatures.Seurat <- function(
  object,
  selection.method = "markvariogram",
  assay = NULL,
  decreasing = TRUE,
  ...
) {
  CheckDots(...)
  assay <- assay %||% DefaultAssay(object = object)
  return(SpatiallyVariableFeatures(
    object = object[[assay]],
    selection.method = selection.method,
    decreasing = decreasing
  ))
}

#' @param save.name Store current identity information under this name
#'
#' @rdname Idents
#' @export
#' @method StashIdent Seurat
#'
StashIdent.Seurat <- function(object, save.name = 'orig.ident', ...) {
  message(
    'With Seurat 3.X, stashing identity classes can be accomplished with the following:\n',
    deparse(expr = substitute(expr = object)),
    '[[',
    deparse(expr = substitute(expr = save.name)),
    ']] <- Idents(object = ',
    deparse(expr = substitute(expr = object)),
    ')'
  )
  CheckDots(...)
  object <- UpdateSlots(object = object)
  object[[save.name]] <- Idents(object = object)
  return(object)
}

#' @param reduction Name of reduction to use
#'
#' @rdname Stdev
#' @export
#' @method Stdev Seurat
#'
#' @examples
#' # Get the standard deviations for each PC from the Seurat object
#' Stdev(object = pbmc_small, reduction = "pca")
#'
Stdev.Seurat <- function(object, reduction = 'pca', ...) {
  CheckDots(...)
  return(Stdev(object = object[[reduction]]))
}

#' @importFrom tools file_path_sans_ext
#'
#' @rdname VariableFeatures
#' @export
#' @method SVFInfo Seurat
#'
#' @order 9
#'
SVFInfo.Seurat <- function(
  object,
  selection.method = c("markvariogram", "moransi"),
  status = FALSE,
  assay = NULL,
  ...
) {
  CheckDots(...)
  assay <- assay %||% DefaultAssay(object = object)
  return(SVFInfo(
    object = object[[assay]],
    selection.method = selection.method,
    status = status
  ))
}

#' @param slot Name of tool to pull
#'
#' @rdname Tool
#' @export
#' @method Tool Seurat
#'
#' @examples
#' Tool(object = pbmc_small)
#'
Tool.Seurat <- function(object, slot = NULL, ...) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  if (is.null(x = slot)) {
    return(names(x = slot(object = object, name = 'tools')))
  }
  return(slot(object = object, name = 'tools')[[slot]])
}

#' @rdname Tool
#' @export
#' @method Tool<- Seurat
#'
#' @examples
#' \dontrun{
#' sample.tool.output <- matrix(data = rnorm(n = 16), nrow = 4)
#' # must be run from within a function
#' Tool(object = pbmc_small) <- sample.tool.output
#' }
"Tool<-.Seurat" <- function(object, ..., value) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  calls <- as.character(x = sys.calls())
  calls <- lapply(
    X = strsplit(x = calls, split = '(', fixed = TRUE),
    FUN = '[',
    1
  )
  tool.call <- min(grep(pattern = 'Tool<-', x = calls))
  if (tool.call <= 1) {
    stop("'Tool<-' cannot be called at the top level", call. = FALSE)
  }
  tool.call <- calls[[tool.call - 1]]
  class.call <- unlist(x = strsplit(
    x = as.character(x = sys.call())[1],
    split = '.',
    fixed = TRUE
  ))
  class.call <- class.call[length(x = class.call)]
  tool.call <- sub(
    pattern = paste0('\\.', class.call, '$'),
    replacement = '',
    x = tool.call,
    perl = TRUE
  )
  slot(object = object, name = 'tools')[[tool.call]] <- value
  return(object)
}

#' @rdname VariableFeatures
#' @export
#' @method VariableFeatures Seurat
#'
#' @order 7
#'
VariableFeatures.Seurat <- function(
  object,
  selection.method = NULL,
  assay = NULL,
  ...
) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  assay <- assay %||% DefaultAssay(object = object)
  return(VariableFeatures(object = object[[assay]], selection.method = selection.method))
}

#' @rdname VariableFeatures
#' @export
#' @method VariableFeatures<- Seurat
#'
#' @order 8
#'
"VariableFeatures<-.Seurat" <- function(object, assay = NULL, ..., value) {
  CheckDots(...)
  object <- UpdateSlots(object = object)
  assay <- assay %||% DefaultAssay(object = object)
  VariableFeatures(object = object[[assay]]) <- value
  return(object)
}

#' @param idents A vector of identity classes to keep
#' @param slot Slot to pull feature data for
#' @param downsample Maximum number of cells per identity class, default is
#' \code{Inf}; downsampling will happen after all other operations, including
#' inverting the cell selection
#' @param seed Random seed for downsampling. If NULL, does not set a seed
#' @inheritDotParams CellsByIdentities
#'
#' @importFrom stats na.omit
#' @importFrom rlang is_quosure enquo eval_tidy
#'
#' @rdname WhichCells
#' @export
#' @method WhichCells Seurat
#'
WhichCells.Seurat <- function(
  object,
  cells = NULL,
  idents = NULL,
  expression,
  slot = 'data',
  invert = FALSE,
  downsample = Inf,
  seed = 1,
  ...
) {
  CheckDots(..., fxns = CellsByIdentities)
  if (!is.null(x = seed)) {
    set.seed(seed = seed)
  }
  object <- UpdateSlots(object = object)
  cells <- cells %||% colnames(x = object)
  if (is.numeric(x = cells)) {
    cells <- colnames(x = object)[cells]
  }
  cell.order <- cells
  if (!is.null(x = idents)) {
    if (any(!idents %in% levels(x = Idents(object = object)))) {
      stop(
        "Cannot find the following identities in the object: ",
        paste(
          idents[!idents %in% levels(x = Idents(object = object))],
          sep = ', '
        )
      )
    }
    cells.idents <- unlist(x = lapply(
      X = idents,
      FUN = function(i) {
        cells.use <- which(x = as.vector(x = Idents(object = object)) == i)
        cells.use <- names(x = Idents(object = object)[cells.use])
        return(cells.use)
      }
    ))
    cells <- intersect(x = cells, y = cells.idents)
  }
  if (!missing(x = expression)) {
    objects.use <- FilterObjects(
      object = object,
      classes.keep = c('Assay', 'DimReduc', 'SpatialImage')
    )
    object.keys <- sapply(
      X = objects.use,
      FUN = function(i) {
        return(Key(object = object[[i]]))
      }
    )
    key.pattern <- paste0('^', object.keys, collapse = '|')
    expr <- if (tryCatch(expr = is_quosure(x = expression), error = function(...) FALSE)) {
      expression
    } else if (is.call(x = enquo(arg = expression))) {
      enquo(arg = expression)
    } else {
      parse(text = expression)
    }
    expr.char <- suppressWarnings(expr = as.character(x = expr))
    expr.char <- unlist(x = lapply(X = expr.char, FUN = strsplit, split = ' '))
    expr.char <- gsub(
      pattern = '(',
      replacement = '',
      x = expr.char,
      fixed = TRUE
    )
    expr.char <- gsub(
      pattern = '`',
      replacement = '',
      x = expr.char
    )
    vars.use <- which(
      x = expr.char %in% rownames(x = object) |
        expr.char %in% colnames(x = object[[]]) |
        grepl(pattern = key.pattern, x = expr.char, perl = TRUE)
    )
    data.subset <- FetchData(
      object = object,
      vars = unique(x = expr.char[vars.use]),
      cells = cells,
      slot = slot
    )
    cells <- rownames(x = data.subset)[eval_tidy(expr = expr, data = data.subset)]
  }
  if (isTRUE(x = invert)) {
    cell.order <- colnames(x = object)
    cells <- colnames(x = object)[!colnames(x = object) %in% cells]
  }
  cells <- CellsByIdentities(object = object, cells = cells, ...)
  cells <- lapply(
    X = cells,
    FUN = function(x) {
      if (length(x = x) > downsample) {
        x <- sample(x = x, size = downsample, replace = FALSE)
      }
      return(x)
    }
  )
  cells <- as.character(x = na.omit(object = unlist(x = cells, use.names = FALSE)))
  cells <- cells[na.omit(object = match(x = cell.order, table = cells))]
  return(cells)
}

#' @rdname Version
#' @method Version Seurat
#' @export
#'
Version.Seurat <- function(object, ...) {
  CheckDots(...)
  return(slot(object = object, name = 'version'))
}

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for R-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#' Seurat Methods
#'
#' Methods for \code{\link{Seurat}} objects for generics defined in other
#' packages
#'
#' @param x,object A \code{\link{Seurat}} object
#' @param i,features Depends on the method
#' \describe{
#'  \item{\code{[}, \code{subset}}{Feature names or indices}
#'  \item{\code{$}, \code{$<-}}{Name of a single metadata column}
#'  \item{\code{[[}, \code{[[<-}}{
#'   Name of one or more metadata columns or an associated object; associated
#'   objects include \code{\link{Assay}}, \code{\link{DimReduc}},
#'   \code{\link{Graph}}, \code{\link{SeuratCommand}}, or
#'   \code{\link{SpatialImage}} objects
#'  }
#' }
#' @param j,cells Cell names or indices
#' @param n The number of rows of metadata to return
#' @param ... Arguments passed to other methods
#'
#' @name Seurat-methods
#' @rdname Seurat-methods
#'
#' @concept seurat
#'
NULL

#' @describeIn Seurat-methods Autocompletion for \code{$} access on a
#' \code{Seurat} object
#'
#' @inheritParams utils::.DollarNames
#'
#' @importFrom utils .DollarNames
#' @export
#' @method .DollarNames Seurat
#'
".DollarNames.Seurat" <- function(x, pattern = '') {
  meta.data <- as.list(x = colnames(x = x[[]]))
  names(x = meta.data) <- unlist(x = meta.data)
  return(.DollarNames(x = meta.data, pattern = pattern))
}

#' @describeIn Seurat-methods Metadata access for \code{Seurat} objects
#'
#' @return \code{$}: metadata column \code{i} for object \code{x};
#' \strong{note}: unlike \code{[[}, \code{$} drops the shape of the metadata
#' to return a vector instead of a data frame
#'
#' @export
#' @method $ Seurat
#'
#' @examples
#' # Get metadata using `$'
#' head(pbmc_small$groups)
#'
"$.Seurat" <- function(x, i, ...) {
  return(x[[i, drop = TRUE]])
}

#' @describeIn Seurat-methods Metadata setter for \code{Seurat} objects
#'
#' @return \code{$<-}: object \code{x} with metadata \code{value} saved as
#' \code{i}
#'
#' @export
#' @method $<- Seurat
#'
#' @examples
#' # Add metadata using the `$' operator
#' set.seed(42)
#' pbmc_small$value <- sample(1:3, size = ncol(pbmc_small), replace = TRUE)
#' head(pbmc_small[["value"]])
#'
"$<-.Seurat" <- function(x, i, ..., value) {
  x[[i]] <- value
  return(x)
}

#' @describeIn Seurat-methods Simple subsetter for \code{Seurat} objects
#'
#' @return \code{[}: object \code{x} with features \code{i} and cells \code{j}
#'
#' @export
#' @method [ Seurat
#'
#' @examples
#' # `[' examples
#' pbmc_small[VariableFeatures(object = pbmc_small), ]
#' pbmc_small[, 1:10]
#'
"[.Seurat" <- function(x, i, j, ...) {
  x <- UpdateSlots(object = x)
  if (missing(x = i) && missing(x = j)) {
    return(x)
  }
  if (missing(x = i)) {
    i <- NULL
  } else if (missing(x = j)) {
    j <- colnames(x = x)
  }
  if (is.logical(x = i)) {
    if (length(i) != nrow(x = x)) {
      stop("Incorrect number of logical values provided to subset features")
    }
    i <- rownames(x = x)[i]
  }
  if (is.logical(x = j)) {
    if (length(j) != ncol(x = x)) {
      stop("Incorrect number of logical values provided to subset cells")
    }
    j <- colnames(x = x)[j]
  }
  if (is.numeric(x = i)) {
    i <- rownames(x = x)[i]
  }
  if (is.numeric(x = j)) {
    j <- colnames(x = x)[j]
  }
  return(subset.Seurat(x = x, features = i, cells = j, ...))
}

#' @describeIn Seurat-methods Metadata and associated object accessor
#'
#' @param drop See \code{\link[base]{drop}}
#'
#' @return \code{[[}: If \code{i} is missing, the metadata data frame; if
#' \code{i} is a vector of metadata names, a data frame with the requested
#' metadata, otherwise, the requested associated object
#'
#' @export
#' @method [[ Seurat
#'
#' @examples
#' # Get the cell-level metadata data frame
#' head(pbmc_small[[]])
#'
#' # Pull specific metadata information
#' head(pbmc_small[[c("letter.idents", "groups")]])
#' head(pbmc_small[["groups", drop = TRUE]])
#'
#' # Get a sub-object (eg. an `Assay' or `DimReduc')
#' pbmc_small[["RNA"]]
#' pbmc_small[["pca"]]
#'
"[[.Seurat" <- function(x, i, ..., drop = FALSE) {
  x <- UpdateSlots(object = x)
  if (missing(x = i)) {
    i <- colnames(x = slot(object = x, name = 'meta.data'))
  }
  if (length(x = i) == 0) {
    return(data.frame(row.names = colnames(x = x)))
  } else if (length(x = i) > 1 || any(i %in% colnames(x = slot(object = x, name = 'meta.data')))) {
    if (any(!i %in% colnames(x = slot(object = x, name = 'meta.data')))) {
      warning(
        "Cannot find the following bits of meta data: ",
        paste0(
          i[!i %in% colnames(x = slot(object = x, name = 'meta.data'))],
          collapse = ', '
        )
      )
    }
    i <- i[i %in% colnames(x = slot(object = x, name = 'meta.data'))]
    data.return <- slot(object = x, name = 'meta.data')[, i, drop = FALSE, ...]
    if (drop) {
      data.return <- unlist(x = data.return, use.names = FALSE)
      names(x = data.return) <- rep.int(x = colnames(x = x), times = length(x = i))
    }
  } else {
    slot.use <- unlist(x = lapply(
      X = c('assays', 'reductions', 'graphs', 'neighbors', 'commands', 'images'),
      FUN = function(s) {
        if (any(i %in% names(x = slot(object = x, name = s)))) {
          return(s)
        }
        return(NULL)
      }
    ))
    if (is.null(x = slot.use)) {
      stop("Cannot find '", i, "' in this Seurat object", call. = FALSE)
    }
    data.return <- slot(object = x, name = slot.use)[[i]]
  }
  return(data.return)
}

#' @describeIn Seurat-methods Number of cells and features for the active assay
#'
#' @return \code{dim}: The number of features (\code{nrow}) and cells
#' (\code{ncol}) for the default assay; \strong{note}: while the number of
#' features changes depending on the active assay, the number of cells remains
#' the same across all assays
#'
#' @export
#' @method dim Seurat
#'
#' @examples
#' # Get the number of features in an object
#' nrow(pbmc_small)
#'
#' # Get the number of cells in an object
#' ncol(pbmc_small)
#'
dim.Seurat <- function(x) {
  x <- UpdateSlots(object = x)
  return(dim(x = x[[DefaultAssay(object = x)]]))
}

#' @describeIn Seurat-methods The cell and feature names for the active assay
#'
#' @return \code{dimnames}: The feature (row) and cell (column) names;
#' \strong{note}: while the features change depending on the active assay, the
#' cell names remain the same across all assays
#'
#' @export
#' @method dimnames Seurat
#'
#' @examples
#' # Get the feature names of an object
#' rownames(pbmc_small)
#'
#' # Get the cell names of an object
#' colnames(pbmc_small)
#'
dimnames.Seurat <- function(x) {
  x <- UpdateSlots(object = x)
  return(dimnames(x = x[[DefaultAssay(object = x)]]))
}

#' @rdname Idents
#' @export
#' @method droplevels Seurat
#'
droplevels.Seurat <- function(x, ...) {
  x <- UpdateSlots(object = x)
  slot(object = x, name = 'active.ident') <- droplevels(x = Idents(object = x), ...)
  return(x)
}

#' @describeIn Seurat-methods Get the first rows of cell-level metadata
#'
#' @return \code{head}: The first \code{n} rows of cell-level metadata
#'
#' @importFrom utils head
#'
#' @export
#' @method head Seurat
#'
#' @examples
#' # Get the first 10 rows of cell-level metadata
#' head(pbmc_small)
#'
head.Seurat <- .head

#' @rdname Idents
#' @export
#' @method levels Seurat
#'
#' @examples
#' # Get the levels of identity classes of a Seurat object
#' levels(x = pbmc_small)
#'
levels.Seurat <- function(x) {
  x <- UpdateSlots(object = x)
  return(levels(x = Idents(object = x)))
}

#' @rdname Idents
#' @export
#' @method levels<- Seurat
#'
#' @examples
#' # Reorder identity classes
#' levels(x = pbmc_small)
#' levels(x = pbmc_small) <- c('C', 'A', 'B')
#' levels(x = pbmc_small)
#'
"levels<-.Seurat" <- function(x, value) {
  x <- UpdateSlots(object = x)
  idents <- Idents(object = x)
  if (!all(levels(x = idents) %in% value)) {
    stop("NA's generated by missing levels", call. = FALSE)
  }
  idents <- factor(x = idents, levels = value)
  Idents(object = x) <- idents
  return(x)
}

#' @describeIn Seurat-methods Merge two or more \code{Seurat} objects together
#'
#' @inheritParams CreateSeuratObject
#' @param y A single \code{Seurat} object or a list of \code{Seurat} objects
#' @param add.cell.ids A character vector of \code{length(x = c(x, y))};
#' appends the corresponding values to the start of each objects' cell names
#' @param merge.data Merge the data slots instead of just merging the counts
#' (which requires renormalization); this is recommended if the same
#' normalization approach was applied to all objects
#' @param merge.dr Merge specified DimReducs that are present in all objects;
#' will only merge the embeddings slots for the first \code{N} dimensions that
#' are shared across all objects.
#'
#' @return \code{merge}: Merged object
#'
#' @section Merge Details:
#' When merging Seurat objects, the merge procedure will merge the Assay level
#' counts and potentially the data slots (depending on the merge.data parameter).
#' It will also merge the cell-level meta data that was stored with each object
#' and preserve the cell identities that were active in the objects pre-merge.
#' The merge will optionally merge reductions depending on the values passed to
#' \code{merge.dr} if they have the same name across objects. Here the
#' embeddings slots will be merged and if there are differing numbers of
#' dimensions across objects, only the first N shared dimensions will be merged.
#' The feature loadings slots will be filled by the values present in the first
#' object.The merge will not preserve graphs, logged commands, or feature-level
#' metadata that were present in the original objects. If add.cell.ids isn't
#' specified and any cell names are duplicated, cell names will be appended
#' with _X, where X is the numeric index of the object in c(x, y).
#'
#' @aliases merge MergeSeurat AddSamples
#'
#' @export
#' @method merge Seurat
#'
#' @examples
#' # `merge' examples
#' # merge two objects
#' merge(pbmc_small, y = pbmc_small)
#' # to merge more than two objects, pass one to x and a list of objects to y
#' merge(pbmc_small, y = c(pbmc_small, pbmc_small))
#'
merge.Seurat <- function(
  x = NULL,
  y = NULL,
  add.cell.ids = NULL,
  merge.data = TRUE,
  merge.dr = NULL,
  project = "SeuratProject",
  ...
) {
  CheckDots(...)
  objects <- c(x, y)
  if (!is.null(x = add.cell.ids)) {
    if (length(x = add.cell.ids) != length(x = objects)) {
      stop("Please provide a cell identifier for each object provided to merge")
    }
    for (i in 1:length(x = objects)) {
      objects[[i]] <- RenameCells(object = objects[[i]], add.cell.id = add.cell.ids[i])
    }
  }
  # ensure unique cell names
  objects <- CheckDuplicateCellNames(object.list = objects)
  assays <- lapply(
    X = objects,
    FUN = FilterObjects,
    classes.keep = 'Assay'
  )
  fake.feature <- RandomName(length = 17)
  assays <- unique(x = unlist(x = assays, use.names = FALSE))
  combined.assays <- vector(mode = 'list', length = length(x = assays))
  names(x = combined.assays) <- assays
  for (assay in assays) {
    assays.merge <- lapply(
      X = objects,
      FUN = function(object) {
        return(tryCatch(
          expr = object[[assay]],
          error = function(e) {
            return(CreateAssayObject(counts = Matrix(
              data = 0,
              ncol = ncol(x = object),
              dimnames = list(fake.feature, colnames(x = object)),
              sparse = TRUE
            )))
          }
        ))
      }
    )
    merged.assay <- merge(
      x = assays.merge[[1]],
      y = assays.merge[2:length(x = assays.merge)],
      merge.data = merge.data
    )
    merged.assay <- subset(
      x = merged.assay,
      features = rownames(x = merged.assay)[rownames(x = merged.assay) != fake.feature]
    )
    if (length(x = Key(object = merged.assay)) == 0) {
      Key(object = merged.assay) <- paste0(assay, '_')
    }
    combined.assays[[assay]] <- merged.assay
  }
  # Merge the meta.data
  combined.meta.data <- data.frame(row.names = colnames(x = combined.assays[[1]]))
  new.idents <- c()
  for (object in objects) {
    old.meta.data <- object[[]]
    if (any(!colnames(x = old.meta.data) %in% colnames(x = combined.meta.data))) {
      cols.to.add <- colnames(x = old.meta.data)[!colnames(x = old.meta.data) %in% colnames(x = combined.meta.data)]
      combined.meta.data[, cols.to.add] <- NA
    }
    # unfactorize any factor columns
    i <- sapply(X = old.meta.data, FUN = is.factor)
    old.meta.data[i] <- lapply(X = old.meta.data[i], FUN = as.vector)
    combined.meta.data[rownames(x = old.meta.data), colnames(x = old.meta.data)] <- old.meta.data
    new.idents <- c(new.idents, as.vector(Idents(object = object)))
  }
  names(x = new.idents) <- rownames(x = combined.meta.data)
  new.idents <- factor(x = new.idents)
  if (DefaultAssay(object = x) %in% assays) {
    new.default.assay <- DefaultAssay(object = x)
  } else if (DefaultAssay(object = y) %in% assays) {
    new.default.assay <- DefaultAssay(object = y)
  } else {
    new.default.assay <- assays[1]
  }
  # Merge images
  combined.images <- vector(
    mode = 'list',
    length = length(x = unlist(x = lapply(X = objects, FUN = Images)))
  )
  index <- 1L
  for (i in 1:length(x = objects)) {
    object <- objects[[i]]
    for (image in Images(object = object)) {
      image.obj <- object[[image]]
      if (image %in% names(x = combined.images)) {
        image <- if (is.null(x = add.cell.ids)) {
          make.unique(names = c(
            na.omit(object = names(x = combined.images)),
            image
          ))[index]
        } else {
          paste(image, add.cell.ids[i], sep = '_')
        }
      }
      combined.images[[index]] <- image.obj
      names(x = combined.images)[index] <- image
      index <- index + 1L
    }
  }
  # Merge DimReducs
  combined.reductions <- list()
  if (!is.null(x = merge.dr)) {
    for (dr in merge.dr) {
      drs.to.merge <- list()
      for (i in 1:length(x = objects)) {
        if (!dr %in% Reductions(object = objects[[i]])) {
          warning("The DimReduc ", dr, " is not present in all objects being ",
                  "merged. Skipping and continuing.", call. = FALSE, immediate. = TRUE)
          break
        }
        drs.to.merge[[i]] <- objects[[i]][[dr]]
      }
      if (length(x = drs.to.merge) == length(x = objects)) {
        combined.reductions[[dr]] <- merge(
          x = drs.to.merge[[1]],
          y = drs.to.merge[2:length(x = drs.to.merge)]
        )
      }
    }
  }
  # Create merged Seurat object
  merged.object <- new(
    Class = 'Seurat',
    assays = combined.assays,
    reductions = combined.reductions,
    images = combined.images,
    meta.data = combined.meta.data,
    active.assay = new.default.assay,
    active.ident = new.idents,
    project.name = project,
    version = packageVersion(pkg = 'SeuratObject')
  )
  return(merged.object)
}

#' @describeIn Seurat-methods Common associated objects
#'
#' @return \code{names}: The names of all \code{\link{Assay}},
#' \code{\link{DimReduc}}, \code{\link{Graph}}, and \code{\link{SpatialImage}}
#' objects in the \code{Seurat} object
#'
#' @export
#' @method names Seurat
#'
#' @examples
#' names(pbmc_small)
#'
names.Seurat <- function(x) {
  return(FilterObjects(
    object = x,
    classes.keep = c('Assay', 'DimReduc', 'Graph', 'SpatialImage')
  ))
}

#' @describeIn Seurat-methods Subset a \code{\link{Seurat}} object
#'
#' @inheritParams CellsByIdentities
#' @param subset Logical expression indicating features/variables to keep
#' @param idents A vector of identity classes to keep
#'
#' @return \code{subset}: A subsetted \code{Seurat} object
#'
#' @importFrom rlang enquo
#
#' @aliases subset
#' @seealso \code{\link[base]{subset}} \code{\link{WhichCells}}
#'
#' @export
#' @method subset Seurat
#'
#' @examples
#' # `subset' examples
#' subset(pbmc_small, subset = MS4A1 > 4)
#' subset(pbmc_small, subset = `DLGAP1-AS1` > 2)
#' subset(pbmc_small, idents = '0', invert = TRUE)
#' subset(pbmc_small, subset = MS4A1 > 3, slot = 'counts')
#' subset(pbmc_small, features = VariableFeatures(object = pbmc_small))
#'
subset.Seurat <- function(
  x,
  subset,
  cells = NULL,
  features = NULL,
  idents = NULL,
  return.null = FALSE,
  ...
) {
  x <- UpdateSlots(object = x)
  if (!missing(x = subset)) {
    subset <- enquo(arg = subset)
  }
  cells <- WhichCells(
    object = x,
    cells = cells,
    idents = idents,
    expression = subset,
    return.null = TRUE,
    ...
  )
  if (length(x = cells) == 0) {
    if (isTRUE(x = return.null)) {
      return(NULL)
    }
    stop("No cells found", call. = FALSE)
  }
  if (all(cells %in% Cells(x = x)) && length(x = cells) == length(x = Cells(x = x)) && is.null(x = features)) {
    return(x)
  }
  if (!all(colnames(x = x) %in% cells)) {
    slot(object = x, name = 'graphs') <- list()
    slot(object = x, name = 'neighbors') <- list()
  }
  assays <- FilterObjects(object = x, classes.keep = 'Assay')
  # Filter Assay objects
  for (assay in assays) {
    assay.features <- features %||% rownames(x = x[[assay]])
    slot(object = x, name = 'assays')[[assay]] <- tryCatch(
      # because subset is also an argument, we need to explictly use the base::subset function
      expr = base::subset(x = x[[assay]], cells = cells, features = assay.features),
      error = function(e) {
        if (e$message == "Cannot find features provided") {
          return(NULL)
        } else {
          stop(e)
        }
      }
    )
  }
  slot(object = x, name = 'assays') <- Filter(
    f = Negate(f = is.null),
    x = slot(object = x, name = 'assays')
  )
  if (length(x = FilterObjects(object = x, classes.keep = 'Assay')) == 0 || is.null(x = x[[DefaultAssay(object = x)]])) {
    stop("Under current subsetting parameters, the default assay will be removed. Please adjust subsetting parameters or change default assay.", call. = FALSE)
  }
  # Filter DimReduc objects
  for (dimreduc in FilterObjects(object = x, classes.keep = 'DimReduc')) {
    x[[dimreduc]] <- tryCatch(
      expr = subset.DimReduc(x = x[[dimreduc]], cells = cells, features = features),
      error = function(e) {
        if (e$message %in% c("Cannot find cell provided", "Cannot find features provided")) {
          return(NULL)
        } else {
          stop(e)
        }
      }
    )
  }
  # Remove metadata for cells not present
  slot(object = x, name = 'meta.data') <- slot(object = x, name = 'meta.data')[cells, , drop = FALSE]
  # Recalculate nCount and nFeature
  for (assay in FilterObjects(object = x, classes.keep = 'Assay')) {
    n.calc <- CalcN(object = x[[assay]])
    if (!is.null(x = n.calc)) {
      names(x = n.calc) <- paste(names(x = n.calc), assay, sep = '_')
      x[[names(x = n.calc)]] <- n.calc
    }
  }
  Idents(object = x, drop = TRUE) <- Idents(object = x)[cells]
  # subset images
  for (image in Images(object = x)) {
    x[[image]] <- base::subset(x = x[[image]], cells = cells)
  }
  return(x)
}

#' @describeIn Seurat-methods Get the last rows of cell-level metadata
#'
#' @return \code{tail}: The last \code{n} rows of cell-level metadata
#'
#' @importFrom utils tail
#'
#' @export
#' @method tail Seurat
#'
#' @examples
#' # Get the last 10 rows of cell-level metadata
#' tail(pbmc_small)
#'
tail.Seurat <- .tail

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# S4 methods
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#' @describeIn Seurat-methods Add cell-level metadata or associated objects
#'
#' @param value Additional metadata or associated objects to add; \strong{note}:
#' can pass \code{NULL} to remove metadata or an associated object
#'
#' @return \code{[[<-}: \code{x} with the metadata or associated objects added
#' as \code{i}; if \code{value} is \code{NULL}, removes metadata or associated
#' object \code{i} from object \code{x}
#'
#' @export
#'
setMethod( # because R doesn't allow S3-style [[<- for S4 classes
  f = '[[<-',
  signature = c('x' = 'Seurat'),
  definition = function(x, i, ..., value) {
    x <- UpdateSlots(object = x)
    # Require names, no index setting
    if (!is.character(x = i)) {
      stop("'i' must be a character", call. = FALSE)
    }
    # Allow removing of other object
    if (is.null(x = value)) {
      slot.use <- if (i %in% colnames(x = x[[]])) {
        'meta.data'
      } else {
        FindObject(object = x, name = i)
      }
      if (is.null(x = slot.use)) {
        stop("Cannot find object ", i, call. = FALSE)
      }
      if (i == DefaultAssay(object = x)) {
        stop("Cannot delete the default assay", call. = FALSE)
      }
    }
    # remove disallowed characters from object name
    newi <- if (is.null(x = value)) {
      i
    } else {
      make.names(names = i)
    }
    if (any(i != newi)) {
      warning(
        "Invalid name supplied, making object name syntactically valid. New object name is ",
        newi,
        "; see ?make.names for more details on syntax validity",
        call. = FALSE,
        immediate. = TRUE
      )
      i <- newi
    }
    # Figure out where to store data
    slot.use <- if (inherits(x = value, what = 'Assay')) {
      # Ensure we have the same number of cells
      if (ncol(x = value) != ncol(x = x)) {
        stop(
          "Cannot add a different number of cells than already present",
          call. = FALSE
        )
      }
      # Ensure cell order stays the same
      if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) {
        for (slot in c('counts', 'data', 'scale.data')) {
          assay.data <- GetAssayData(object = value, slot = slot)
          if (!IsMatrixEmpty(x = assay.data)) {
            assay.data <- assay.data[, Cells(x = x), drop = FALSE]
          }
          # Use slot because SetAssayData is being weird
          slot(object = value, name = slot) <- assay.data
        }
      }
      'assays'
    } else if (inherits(x = value, what = 'SpatialImage')) {
      # Ensure that all cells for this image are present
      if (!all(Cells(x = value) %in% Cells(x = x))) {
        stop("All cells in the image must be present in assay.", call. = FALSE)
      }
      # Ensure Assay that SpatialImage is associated with is present in Seurat object
      if (!DefaultAssay(object = value) %in% Assays(object = x)) {
        warning(
          "Adding image data that isn't associated with any assay present",
          call. = FALSE,
          immediate. = TRUE
        )
      }
      'images'
    } else if (inherits(x = value, what = 'Graph')) {
      # Ensure Assay that Graph is associated with is present in the Seurat object
      if (is.null(x = DefaultAssay(object = value))) {
        warning(
          "Adding a Graph without an assay associated with it",
          call. = FALSE,
          immediate. = TRUE
        )
      } else if (!any(DefaultAssay(object = value) %in% Assays(object = x))) {
        stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE)
      }
      # Ensure Graph object is in order
      if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) {
        value <- value[Cells(x = x), Cells(x = x)]
      }
      'graphs'
    } else if (inherits(x = value, what = 'DimReduc')) {
      # All DimReducs must be associated with an Assay
      if (is.null(x = DefaultAssay(object = value))) {
        stop("Cannot add a DimReduc without an assay associated with it", call. = FALSE)
      }
      # Ensure Assay that DimReduc is associated with is present in the Seurat object
      if (!IsGlobal(object = value) && !any(DefaultAssay(object = value) %in% Assays(object = x))) {
        stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE)
      }
      # Ensure DimReduc object is in order
      if (all(Cells(x = value) %in% Cells(x = x)) && !all(Cells(x = value) == Cells(x = x))) {
        slot(object = value, name = 'cell.embeddings') <- value[[Cells(x = x), ]]
      }
      'reductions'
    } else if (inherits(x = value, what = "Neighbor")) {
      # Ensure all cells are present in the Seurat object
      if (length(x = Cells(x = value)) > length(x = Cells(x = x))) {
        stop(
          "Cannot have more cells in the Neighbor object than are present in the Seurat object.",
          call. = FALSE
        )
      }
      if (!all(Cells(x = value) %in% Cells(x = x))) {
        stop(
          "Cannot add cells in the Neighbor object that aren't present in the Seurat object.",
          call. = FALSE
        )
      }
      'neighbors'
    } else if (inherits(x = value, what = 'SeuratCommand')) {
      # Ensure Assay that SeuratCommand is associated with is present in the Seurat object
      if (is.null(x = DefaultAssay(object = value))) {
        warning(
          "Adding a command log without an assay associated with it",
          call. = FALSE,
          immediate. = TRUE
        )
      } else if (!any(DefaultAssay(object = value) %in% Assays(object = x))) {
        stop("Cannot find assay '", DefaultAssay(object = value), "' in this Seurat object", call. = FALSE)
      }
      'commands'
    } else if (is.null(x = value)) {
      slot.use
    } else {
      'meta.data'
    }
    if (slot.use == 'meta.data') {
      # Add data to object metadata
      meta.data <- x[[]]
      cell.names <- rownames(x = meta.data)
      # If we have metadata with names, ensure they match our order
      if (is.data.frame(x = value) && !is.null(x = rownames(x = value))) {
        meta.order <- match(x = rownames(x = meta.data), table = rownames(x = value))
        value <- value[meta.order, , drop = FALSE]
      }
      if (length(x = i) > 1) {
        # Add multiple pieces of metadata
        value <- rep_len(x = value, length.out = length(x = i))
        for (index in 1:length(x = i)) {
          meta.data[i[index]] <- value[index]
        }
      } else {
        # Add a single column to metadata
        if (length(x = intersect(x = names(x = value), y = cell.names)) > 0) {
          meta.data[, i] <- value[cell.names]
        } else if (length(x = value) %in% c(nrow(x = meta.data), 1) || is.null(x = value)) {
          meta.data[, i] <- value
        } else {
          stop("Cannot add more or fewer cell meta.data information without values being named with cell names", call. = FALSE)
        }
      }
      # Check to ensure that we aren't adding duplicate names
      if (any(colnames(x = meta.data) %in% FilterObjects(object = x))) {
        bad.cols <- colnames(x = meta.data)[which(colnames(x = meta.data) %in% FilterObjects(object = x))]
        stop(
          paste0(
            "Cannot add a metadata column with the same name as an Assay or DimReduc - ",
            paste(bad.cols, collapse = ", ")),
          call. = FALSE
        )
      }
      # Store the revised metadata
      slot(object = x, name = 'meta.data') <- meta.data
    } else {
      # Add other object to Seurat object
      # Ensure cells match in value and order
      if (!inherits(x = value, what = c('SeuratCommand', 'NULL', 'SpatialImage', 'Neighbor')) && !all(Cells(x = value) == Cells(x = x))) {
        stop("All cells in the object being added must match the cells in this object", call. = FALSE)
      }
      # Ensure we're not duplicating object names
      duplicate <- !is.null(x = FindObject(object = x, name = i)) &&
        !inherits(x = value, what = c(class(x = x[[i]]), 'NULL')) &&
        !inherits(x = x[[i]], what = class(x = value))
      if (isTRUE(x = duplicate)) {
        stop(
          "This object already contains ",
          i,
          " as a",
          ifelse(
            test = tolower(x = substring(text = class(x = x[[i]]), first = 1, last = 1)) %in% c('a', 'e', 'i', 'o', 'u'),
            yes = 'n ',
            no = ' '
          ),
          class(x = x[[i]]),
          ", so ",
          i,
          " cannot be used for a ",
          class(x = value),
          call. = FALSE
        )
      }
      # Check keyed objects
      if (inherits(x = value, what = c('Assay', 'DimReduc', 'SpatialImage'))) {
        if (length(x = Key(object = value)) == 0 || nchar(x = Key(object = value)) == 0) {
          Key(object = value) <- paste0(tolower(x = i), '_')
        }
        Key(object = value) <- UpdateKey(key = Key(object = value))
        # Check for duplicate keys
        object.keys <- Key(object = x)
        vkey <- Key(object = value)
        if (vkey %in% object.keys && !isTRUE(x = object.keys[i] == vkey)) {
          new.key <- if (is.na(x = object.keys[i])) {
            # Attempt to create a duplicate key based off the name of the object being added
            new.keys <- paste0(
              paste0(tolower(x = i), c('', RandomName(length = 2L))),
              '_'
            )
            # Select new key to use
            key.use <- min(which(x = !new.keys %in% object.keys))
            new.key <- if (is.infinite(x = key.use)) {
              RandomName(length = 17L)
            } else {
              new.keys[key.use]
            }
            warning(
              "Cannot add objects with duplicate keys (offending key: ",
              Key(object = value),
              "), setting key to '",
              new.key,
              "'",
              call. = FALSE
            )
            new.key
          } else {
            # Use existing key
            warning(
              "Cannot add objects with duplicate keys (offending key: ",
              Key(object = value),
              ") setting key to original value '",
              object.keys[i],
              "'",
              call. = FALSE
            )
            object.keys[i]
          }
          # Set new key
          Key(object = value) <- new.key
        }
      }
      # For Assays, run CalcN
      if (inherits(x = value, what = 'Assay')) {
        if ((!i %in% Assays(object = x)) |
            (i %in% Assays(object = x) && !identical(
              x = GetAssayData(object = x, assay = i, slot = "counts"),
              y = GetAssayData(object = value, slot = "counts"))
            )) {
          n.calc <- CalcN(object = value)
          if (!is.null(x = n.calc)) {
            names(x = n.calc) <- paste(names(x = n.calc), i, sep = '_')
            x[[names(x = n.calc)]] <- n.calc
          }
        }
      }
      # When removing an Assay, clear out associated DimReducs, Graphs, and SeuratCommands
      if (is.null(x = value) && inherits(x = x[[i]], what = 'Assay')) {
        objs.assay <- FilterObjects(
          object = x,
          classes.keep = c('DimReduc', 'SeuratCommand', 'Graph')
        )
        objs.assay <- Filter(
          f = function(o) {
            return(all(DefaultAssay(object = x[[o]]) == i) && !IsGlobal(object = x[[o]]))
          },
          x = objs.assay
        )
        for (o in objs.assay) {
          x[[o]] <- NULL
        }
      }
      # If adding a command, ensure it gets put at the end of the command list
      if (inherits(x = value, what = 'SeuratCommand')) {
        slot(object = x, name = slot.use)[[i]] <- NULL
        slot(object = x, name = slot.use) <- Filter(
          f = Negate(f = is.null),
          x = slot(object = x, name = slot.use)
        )
      }
      slot(object = x, name = slot.use)[[i]] <- value
      slot(object = x, name = slot.use) <- Filter(
        f = Negate(f = is.null),
        x = slot(object = x, name = slot.use)
      )
    }
    CheckGC()
    return(x)
  }
)

#' @describeIn Seurat-methods Calculate \code{\link[base]{colMeans}} on a
#' \code{Seurat} object
#'
#' @param slot Name of assay expression matrix to calculate column/row
#' means/sums on
#' @inheritParams Matrix::colMeans
#'
#' @importFrom Matrix colMeans
#'
#' @export
#'
#' @examples
#' head(colMeans(pbmc_small))
#'
setMethod(
  f = 'colMeans',
  signature = c('x' = 'Seurat'),
  definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
    return(colMeans(
      x = GetAssayData(object = x, slot = slot),
      na.rm = na.rm,
      dims = dims,
      ...
    ))
  }
)

#' @describeIn Seurat-methods Calculate \code{\link[base]{colSums}} on a
#' \code{Seurat} object
#'
#' @importFrom Matrix colSums
#'
#' @export
#'
#' @examples
#' head(colSums(pbmc_small))
#'
setMethod(
  f = 'colSums',
  signature = c('x' = 'Seurat'),
  definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
    return(Matrix::colSums(
      x = GetAssayData(object = x, slot = slot),
      na.rm = na.rm,
      dims = dims,
      ...
    ))
  }
)

#' @describeIn Seurat-methods Calculate \code{\link[base]{rowMeans}} on a
#' \code{rowMeans} object
#'
#' @importFrom Matrix colSums
#'
#' @export
#'
#' @examples
#' head(rowMeans(pbmc_small))
#'
setMethod(
  f = 'rowMeans',
  signature = c('x' = 'Seurat'),
  definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
    return(Matrix::rowMeans(
      x = GetAssayData(object = x, slot = slot),
      na.rm = na.rm,
      dims = dims,
      ...
    ))
  }
)

#' @describeIn Seurat-methods Calculate \code{\link[base]{rowSums}} on a
#' \code{Seurat} object
#'
#' @importFrom Matrix rowSums
#'
#' @export
#'
#' @examples
#' head(rowSums(pbmc_small))
#'
setMethod(
  f = 'rowSums',
  signature = c('x' = 'Seurat'),
  definition = function(x, na.rm = FALSE, dims = 1, ..., slot = 'data') {
    return(Matrix::rowSums(
      x = GetAssayData(object = x, slot = slot),
      na.rm = na.rm,
      dims = dims,
      ...
    ))
  }
)

#' @describeIn Seurat-methods Overview of a \code{Seurat} object
#'
#' @return \code{show}: Prints summary to \code{\link[base]{stdout}} and
#' invisibly returns \code{NULL}
#'
#' @importFrom methods show
#'
#' @export
#'
setMethod(
  f = "show",
  signature = "Seurat",
  definition = function(object) {
    object <- UpdateSlots(object = object)
    assays <- FilterObjects(object = object, classes.keep = 'Assay')
    nfeatures <- sum(vapply(
      X = assays,
      FUN = function(x) {
        return(nrow(x = object[[x]]))
      },
      FUN.VALUE = integer(length = 1L)
    ))
    num.assays <- length(x = assays)
    cat("An object of class", class(x = object), "\n")
    cat(
      nfeatures,
      'features across',
      ncol(x = object),
      'samples within',
      num.assays,
      ifelse(test = num.assays == 1, yes = 'assay', no = 'assays'),
      "\n"
    )
    cat(
      "Active assay:",
      DefaultAssay(object = object),
      paste0('(', nrow(x = object), ' features, ', length(x = VariableFeatures(object = object)), ' variable features)')
    )
    other.assays <- assays[assays != DefaultAssay(object = object)]
    if (length(x = other.assays) > 0) {
      cat(
        '\n',
        length(x = other.assays),
        'other',
        ifelse(test = length(x = other.assays) == 1, yes = 'assay', no = 'assays'),
        'present:',
        strwrap(x = paste(other.assays, collapse = ', '))
      )
    }
    reductions <- FilterObjects(object = object, classes.keep = 'DimReduc')
    if (length(x = reductions) > 0) {
      cat(
        '\n',
        length(x = reductions),
        'dimensional',
        ifelse(test = length(x = reductions) == 1, yes = 'reduction', no = 'reductions'),
        'calculated:',
        strwrap(x = paste(reductions, collapse = ', '))
      )
    }
    fovs <- FilterObjects(object = object, classes.keep = 'FOV')
    if (length(x = fovs)) {
      cat(
        '\n',
        length(x = fovs),
        'spatial',
        ifelse(test = length(x = fovs) == 1L, yes = 'field', no = 'fields'),
        'of view present:',
        strwrap(x = paste(fovs, sep = ', '))
      )
    }
    images <- FilterObjects(object = object, classes.keep = 'SpatialImage')
    images <- setdiff(x = images, y = fovs)
    if (length(x = images)) {
      cat(
        '\n',
        length(x = images),
        ifelse(test = length(x = images) == 1L, yes = 'image', no = 'images'),
        'present:',
        strwrap(x = paste(images, collapse = ', '))
      )
    }
    cat('\n')
  }
)

#' @rdname oldseurat-class
#'
#' @inheritParams Seurat-methods
#'
#' @importFrom methods show
#'
setMethod(
  f = 'show',
  signature = 'seurat',
  definition = function(object) {
    cat(
      "An old seurat object\n",
      nrow(x = object@data),
      'genes across',
      ncol(x = object@data),
      'samples\n'
    )
  }
)

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Internal
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#' Object Collections
#'
#' Find the names of collections in an object
#'
#' @param object An S4 object
#'
#' @return A vector with the names of slots that are a list
#'
#' @keywords internal
#'
#' @noRd
#'
#' @examples
#' \donttest{
#' SeuratObject:::Collections(pbmc_small)
#' }
#'
Collections <- function(object) {
  if (!isS4(object)) {
    return(NULL)
  }
  collections <- vapply(
    X = slotNames(x = object),
    FUN = function(x) {
      return(inherits(x = slot(object = object, name = x), what = 'list'))
    },
    FUN.VALUE = logical(length = 1L)
  )
  collections <- Filter(f = isTRUE, x = collections)
  return(names(x = collections))
}

#' Get the default image of an object
#'
#' Attempts to find all images associated with the default assay of the object.
#' If none present, finds all images present in the object. Returns the name of
#' the first image
#'
#' @param object A \code{\link{Seurat}} object
#'
#' @return The name of the default image
#'
#' @keywords internal
#'
#' @noRd
#'
DefaultImage <- function(object) {
  object <- UpdateSlots(object = object)
  images <- Images(object = object, assay = DefaultAssay(object = object))
  if (length(x = images) < 1) {
    images <- Images(object = object)
  }
  return(images[[1]])
}

#' Find the collection of an object within a Seurat object
#'
#' @param object A \code{\link{Seurat}} object
#' @param name Name of object to find
#'
#' @return The collection (slot) of the object
#'
#' @keywords internal
#'
#' @noRd
#'
#' @examples
#' \donttest{
#' SeuratObject:::FindObject(pbmc_small, name = "RNA")
#' }
#'
FindObject <- function(object, name) {
  collections <- c(
    'assays',
    'graphs',
    'neighbors',
    'reductions',
    'commands',
    'images'
  )
  object.names <- lapply(
    X = collections,
    FUN = function(x) {
      return(names(x = slot(object = object, name = x)))
    }
  )
  names(x = object.names) <- collections
  object.names <- Filter(f = Negate(f = is.null), x = object.names)
  for (i in names(x = object.names)) {
    if (name %in% names(x = slot(object = object, name = i))) {
      return(i)
    }
  }
  return(NULL)
}

#' Update Seurat v2 Internal Objects
#'
#' Helper functions to update old Seurat v2 objects to v3/v4 objects
#'
#' @param old.assay,old.dr,old.jackstraw Seurat v2 assay, dimensional
#' reduction, or jackstraw object
#' @param assay Name to store for assay in new object
#'
#' @return A v3/v4 \code{\link{Assay}}, \code{\link{DimReduc}}, or
#' \code{\link{JackStrawData}} object
#'
#' @name V2Update
#' @rdname V2Update
#'
#' @keywords internal
#'
#' @noRd
#'
UpdateAssay <- function(old.assay, assay) {
  if (!is.null(x = old.assay@data)) {
    cells <- colnames(x = old.assay@data)
  } else {
    cells <- colnames(x = old.assay@raw.data)
  }
  counts <- old.assay@raw.data
  data <- old.assay@data
  if (!inherits(x = counts, what = 'dgCMatrix')) {
    counts <- as.sparse(x = as.matrix(x = counts))
  }
  if (!is.null(x = data)) {
    if (!inherits(x = data, what = 'dgCMatrix')) {
      data <- as.sparse(x = as.matrix(x = data))
    }
  } else {
    data <- as.sparse(
      x = Matrix(
        data = 0,
        nrow = nrow(x = counts),
        ncol = ncol(x = counts),
        dimnames = dimnames(x = counts)
      ),
    )
  }
  if (!inherits(x = old.assay@scale.data, what = 'matrix')) {
    scale.data <- new(Class = 'matrix')
  } else {
    scale.data <- old.assay@scale.data
  }
  new.assay <- new(
    Class = 'Assay',
    counts = counts[, cells],
    data = data,
    scale.data = scale.data,
    meta.features = data.frame(row.names = rownames(x = counts)),
    var.features = old.assay@var.genes,
    key = paste0(assay, "_")
  )
  return(new.assay)
}

#' @param assay.used Name of assay used to compute dimension reduction
#'
#' @importFrom methods new
#'
#' @rdname V2Update
#'
#' @noRd
#'
UpdateDimReduction <- function(old.dr, assay) {
  new.dr <- list()
  for (i in names(x = old.dr)) {
    cell.embeddings <- old.dr[[i]]@cell.embeddings %||% new(Class = 'matrix')
    feature.loadings <- old.dr[[i]]@gene.loadings %||% new(Class = 'matrix')
    stdev <- old.dr[[i]]@sdev %||% numeric()
    misc <- old.dr[[i]]@misc %||% list()
    new.jackstraw <- UpdateJackstraw(old.jackstraw = old.dr[[i]]@jackstraw)
    old.key <- old.dr[[i]]@key
    if (length(x = old.key) == 0) {
      old.key <- gsub(pattern = "(.+?)(([0-9]+).*)", replacement = "\\1",  x = colnames(cell.embeddings)[[1]])
      if (length(x = old.key) == 0) {
        old.key <- i
      }
    }
    new.key <- suppressWarnings(expr = UpdateKey(key = old.key))
    colnames(x = cell.embeddings) <- gsub(
      pattern = old.key,
      replacement = new.key,
      x = colnames(x = cell.embeddings)
    )
    colnames(x = feature.loadings) <- gsub(
      pattern = old.key,
      replacement = new.key,
      x = colnames(x = feature.loadings)
    )
    new.dr[[i]] <- new(
      Class = 'DimReduc',
      cell.embeddings = as(object = cell.embeddings, Class = 'matrix'),
      feature.loadings = as(object = feature.loadings, Class = 'matrix'),
      assay.used = assay,
      stdev = as(object = stdev, Class = 'numeric'),
      key = as(object = new.key, Class = 'character'),
      jackstraw = new.jackstraw,
      misc = as(object = misc, Class = 'list')
    )
  }
  return(new.dr)
}

#' @importFrom methods .hasSlot new
#'
#' @rdname V2Update
#'
#' @keywords internal
#'
#' @noRd
#'
UpdateJackstraw <- function(old.jackstraw) {
  if (is.null(x = old.jackstraw)) {
    new.jackstraw <- new(
      Class = 'JackStrawData',
      empirical.p.values = new(Class = 'matrix'),
      fake.reduction.scores = new(Class = 'matrix'),
      empirical.p.values.full = new(Class = 'matrix'),
      overall.p.values = new(Class = 'matrix')
    )
  } else {
    if (.hasSlot(object = old.jackstraw, name = 'overall.p.values')) {
      overall.p <- old.jackstraw@overall.p.values %||% new(Class = 'matrix')
    } else {
      overall.p <- new(Class = 'matrix')
    }
    new.jackstraw <- new(
      Class = 'JackStrawData',
      empirical.p.values = old.jackstraw@emperical.p.value %||% new(Class = 'matrix'),
      fake.reduction.scores = old.jackstraw@fake.pc.scores %||% new(Class = 'matrix'),
      empirical.p.values.full = old.jackstraw@emperical.p.value.full %||% new(Class = 'matrix'),
      overall.p.values = overall.p
    )
  }
  return(new.jackstraw)
}
